bin/common.ml at inline-small-objects

vblt.org / irmini
forked from gazagnaire.org/irmin
fork atom
Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
fork atom
irmini / bin / common.ml
at inline-small-objects 205 lines 6.6 kB view raw
wrap content
Thomas Gazagnaire Sync from checkouts 2mo ago
935552b5
  1(** Common CLI helpers. *)
  2
  3open Irmin
  4
  5(* Output helpers using Tty *)
  6let success fmt =
  7  let style = Tty.Style.(fg Tty.Color.green) in
  8  Fmt.pr ("%a " ^^ fmt ^^ "@.") (Tty.Style.styled style Fmt.string) "✓"
  9
 10let error fmt =
 11  let style = Tty.Style.(fg Tty.Color.red) in
 12  Fmt.epr ("%a " ^^ fmt ^^ "@.") (Tty.Style.styled style Fmt.string) "✗"
 13
 14let styled_bold = Tty.Style.(styled bold Fmt.string)
 15let styled_cyan = Tty.Style.(styled (fg Tty.Color.cyan) Fmt.string)
 16let styled_faint = Tty.Style.(styled faint Fmt.string)
 17let styled_yellow = Tty.Style.(styled (fg Tty.Color.yellow) Fmt.string)
 18let styled_blue = Tty.Style.(styled (fg Tty.Color.blue) Fmt.string)
 19
 20let path_of_string s =
 21  String.split_on_char '/' s |> List.filter (fun s -> s <> "")
 22
 23type log_entry = { hash : string; author : string; message : string }
 24(** Log entry for commit history. *)
 25
 26(** Backend module signature - first-class modules for extensibility. *)
 27module type BACKEND = sig
 28  type store
 29  type tree
 30  type hash
 31
 32  val open_store :
 33    sw:Eio.Switch.t -> fs:Eio.Fs.dir_ty Eio.Path.t -> config:Config.t -> store
 34
 35  val checkout : store -> branch:string -> tree option
 36  val empty_tree : store -> tree
 37  val tree_find : tree -> string list -> string option
 38  val tree_add : tree -> string list -> string -> tree
 39  val tree_remove : tree -> string list -> tree
 40  val tree_list : tree -> string list -> (string * [ `Contents | `Node ]) list
 41  val head : store -> branch:string -> hash option
 42
 43  val commit :
 44    store ->
 45    tree:tree ->
 46    parents:hash list ->
 47    message:string ->
 48    author:string ->
 49    hash
 50
 51  val set_head : store -> branch:string -> hash -> unit
 52  val branches : store -> string list
 53  val log : store -> branch:string -> limit:int option -> log_entry list
 54  val hash_to_hex : hash -> string
 55  val hash_short : hash -> string
 56end
 57
 58(** Git backend implementation. *)
 59module Git : BACKEND = struct
 60  type store = Store.Git.t
 61  type tree = Tree.Git.t
 62  type hash = Hash.sha1
 63
 64  let open_store ~sw ~fs ~config =
 65    let git_dir = Fpath.(v config.Config.store_path / ".git") in
 66    Git_interop.import_git ~sw ~fs ~git_dir
 67
 68  let checkout store ~branch = Store.Git.checkout store ~branch
 69  let empty_tree _store = Tree.Git.empty ()
 70  let tree_find tree path = Tree.Git.find tree path
 71  let tree_add tree path content = Tree.Git.add tree path content
 72  let tree_remove tree path = Tree.Git.remove tree path
 73  let tree_list tree path = Tree.Git.list tree path
 74  let head store ~branch = Store.Git.head store ~branch
 75
 76  let commit store ~tree ~parents ~message ~author =
 77    Store.Git.commit store ~tree ~parents ~message ~author
 78
 79  let set_head store ~branch hash = Store.Git.set_head store ~branch hash
 80  let branches store = Store.Git.branches store
 81
 82  let log store ~branch ~limit =
 83    let rec walk n hash acc =
 84      if n = Some 0 then List.rev acc
 85      else
 86        match Store.Git.read_commit store hash with
 87        | None -> List.rev acc
 88        | Some commit -> (
 89            let entry =
 90              {
 91                hash = Hash.to_hex hash;
 92                author = Commit.Git.author commit;
 93                message = Commit.Git.message commit;
 94              }
 95            in
 96            match Commit.Git.parents commit with
 97            | [] -> List.rev (entry :: acc)
 98            | p :: _ -> walk (Option.map pred n) p (entry :: acc))
 99    in
100    match Store.Git.head store ~branch with
101    | None -> []
102    | Some h -> walk limit h []
103
104  let hash_to_hex h = Hash.to_hex h
105  let hash_short h = String.sub (Hash.to_hex h) 0 7
106end
107
108(** MST backend implementation using ATProto blockstore. *)
109module Mst : BACKEND = struct
110  type store = Atp.Blockstore.writable
111  type tree = Atp.Mst.node * Atp.Blockstore.writable
112  type hash = Atp.Cid.t
113
114  let open_store ~sw:_ ~fs ~config =
115    match config.Config.backend with
116    | Config.Memory -> Atp.Blockstore.memory ()
117    | Config.Mst | Config.Git ->
118        let irmin_dir = Filename.concat config.Config.store_path ".irmin" in
119        (try Unix.mkdir irmin_dir 0o755 with Unix.Unix_error _ -> ());
120        let blocks_path = Eio.Path.(fs / irmin_dir / "blocks") in
121        Atp.Blockstore.filesystem blocks_path
122
123  let checkout _store ~branch =
124    (* TODO: Load root from refs *)
125    ignore branch;
126    None
127
128  let empty_tree store = (Atp.Mst.empty, store)
129
130  let tree_find (mst, bs) path =
131    let key = String.concat "/" path in
132    match Atp.Mst.get key mst ~store:(bs :> Atp.Blockstore.readable) with
133    | None -> None
134    | Some cid -> bs#get cid
135
136  let tree_add (mst, bs) path content =
137    let key = String.concat "/" path in
138    let cid = Atp.Cid.of_string content in
139    bs#put cid content;
140    let mst' = Atp.Mst.add key cid mst ~store:bs in
141    (mst', bs)
142
143  let tree_remove (mst, bs) path =
144    let key = String.concat "/" path in
145    let mst' = Atp.Mst.remove key mst ~store:bs in
146    (mst', bs)
147
148  let tree_list (mst, bs) path =
149    let prefix =
150      match path with [] -> "" | _ -> String.concat "/" path ^ "/"
151    in
152    Atp.Mst.leaves mst ~store:(bs :> Atp.Blockstore.readable)
153    |> Seq.filter_map (fun (k, _cid) ->
154        if
155          prefix = ""
156          || String.length k > String.length prefix
157             && String.sub k 0 (String.length prefix) = prefix
158        then
159          let suffix =
160            String.sub k (String.length prefix)
161              (String.length k - String.length prefix)
162          in
163          match String.index_opt suffix '/' with
164          | None -> Some (suffix, `Contents)
165          | Some i -> Some (String.sub suffix 0 i, `Node)
166        else None)
167    |> List.of_seq |> List.sort_uniq compare
168
169  let head _store ~branch =
170    (* TODO: Store refs in blockstore *)
171    ignore branch;
172    None
173
174  let commit bs ~tree:(mst, _) ~parents ~message ~author =
175    ignore parents;
176    ignore message;
177    ignore author;
178    let cid = Atp.Mst.to_cid mst ~store:bs in
179    bs#sync;
180    cid
181
182  let set_head _store ~branch _hash =
183    (* TODO: Store refs *)
184    ignore branch
185
186  let branches _store = [ "main" ]
187
188  let log _store ~branch ~limit =
189    (* MST stores don't have traditional commit history *)
190    ignore branch;
191    ignore limit;
192    []
193
194  let hash_to_hex cid = Atp.Cid.to_string cid
195
196  let hash_short cid =
197    let s = Atp.Cid.to_string cid in
198    if String.length s > 7 then String.sub s 0 7 else s
199end
200
201(** Get the appropriate backend module for a configuration. *)
202let backend_of_config (config : Config.t) : (module BACKEND) =
203  match config.backend with
204  | Config.Git -> (module Git)
205  | Config.Mst | Config.Memory -> (module Mst)