diff --git a/src/bin_validation/validator.ml b/src/bin_validation/validator.ml index c8ac1871e712dd83e3204f5b52cc522396d65931..ce9a5aedb3e688d5e2752605de704bcd5925781c 100644 --- a/src/bin_validation/validator.ml +++ b/src/bin_validation/validator.ml @@ -98,6 +98,15 @@ module Events = struct ~pp1:Block_header.pp ("block", Block_header.encoding) + let unload_request = + declare_1 + ~section + ~level:Debug + ~name:"unload_request" + ~msg:"unloading context below {context_hash}" + ~pp1:Context_hash.pp + ("context_hash", Context_hash.encoding) + let termination_request = declare_0 ~section @@ -459,6 +468,16 @@ let run input output = context_hash)) in loop cache None + | External_validation.Unload {context_hash} -> + let*! () = Events.(emit unload_request context_hash) in + let*! () = Context.gc context_index context_hash in + let*! () = + External_validation.send + output + (Error_monad.result_encoding Data_encoding.empty) + (Ok ()) + in + loop cache None | External_validation.Terminate -> let*! () = Lwt_io.flush_all () in Events.(emit termination_request ()) diff --git a/src/lib_context/disk/context.ml b/src/lib_context/disk/context.ml index 0a0d7625323dc2e53a66610626ff8ca93b1d983d..855c8c930baccd3e06086874b22b2995be606cd3 100644 --- a/src/lib_context/disk/context.ml +++ b/src/lib_context/disk/context.ml @@ -32,6 +32,7 @@ type error += | Cannot_create_file of string | Cannot_open_file of string + | Cannot_retrieve_commit_info of Context_hash.t | Cannot_find_protocol | Suspicious_file of int @@ -62,6 +63,20 @@ let () = Data_encoding.(obj1 (req "context_restore_cannot_open" string)) (function Cannot_open_file e -> Some e | _ -> None) (fun e -> Cannot_open_file e) ; + register_error_kind + `Permanent + ~id:"cannot_retrieve_commit_info" + ~title:"Cannot retrieve commit info" + ~description:"" + ~pp:(fun ppf hash -> + Format.fprintf + ppf + "@[Cannot retrieve commit info associated to context hash %a@]" + Context_hash.pp + hash) + Data_encoding.(obj1 (req "context_hash" Context_hash.encoding)) + (function Cannot_retrieve_commit_info e -> Some e | _ -> None) + (fun e -> Cannot_retrieve_commit_info e) ; register_error_kind `Permanent ~id:"context_dump.cannot_find_protocol" @@ -89,6 +104,7 @@ module type TEZOS_CONTEXT_UNIX = sig type error += | Cannot_create_file of string | Cannot_open_file of string + | Cannot_retrieve_commit_info of Context_hash.t | Cannot_find_protocol | Suspicious_file of int @@ -251,6 +267,7 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct type error += | Cannot_create_file = Cannot_create_file | Cannot_open_file = Cannot_open_file + | Cannot_retrieve_commit_info = Cannot_retrieve_commit_info | Cannot_find_protocol = Cannot_find_protocol | Suspicious_file = Suspicious_file @@ -390,11 +407,53 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct let commit = P.Commit_portable.v ~parents ~node ~info in Hash.to_context_hash (Commit_hash.hash commit) + let finalise_gc_and_log repo = + let open Lwt_syntax in + let catch_errors error = + let error_msg = + match error with + | Irmin_pack_unix.Errors.Pack_error error -> + Fmt.str "Pack_error: %a" Irmin_pack_unix.Errors.pp_base_error error + | Irmin.Closed -> "Closed" + | Irmin_pack.RO_not_allowed -> "RO_not_allowed" + | Unix.Unix_error (err, s1, s2) -> + let pp = Irmin.Type.pp Irmin_pack_unix.Io.Unix.misc_error_t in + Fmt.str "Unix_error: %a" pp (err, s1, s2) + | exn -> raise exn + in + Format.printf "Finalising Gc resulted in error %s@." error_msg ; + Lwt.return_unit + in + Lwt.catch + (fun () -> + let c0 = Mtime_clock.counter () in + let* gc_done = Store.finalise_gc ~wait:true repo in + let span = Mtime_clock.count c0 |> Mtime.Span.to_ms in + if gc_done then Format.printf "Gc ended, it took %.4fms@." span ; + Lwt.return_unit) + catch_errors + let commit ~time ?message context = let open Lwt_syntax in let+ commit = raw_commit ~time ?message context in Hash.to_context_hash (Store.Commit.hash commit) + let gc index context_hash = + let open Lwt_syntax in + let repo = index.repo in + let* commit_opt = + Store.Commit.of_hash index.repo (Hash.of_context_hash context_hash) + in + match commit_opt with + | None -> + Fmt.failwith "%a: unknown context hash" Context_hash.pp context_hash + | Some commit -> + let commit_key = Store.Commit.key commit in + Format.printf "Trigger GC for commit %a@." Context_hash.pp context_hash ; + let* _ = Store.start_gc ~throttle:`Block repo commit_key in + Lwt.async (fun () -> finalise_gc_and_log index.repo) ; + Lwt.return_unit + (*-- Generic Store Primitives ------------------------------------------------*) let data_key key = current_data_key @ key @@ -1067,23 +1126,29 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct Hash.to_context_hash (Store.Tree.hash tree) let retrieve_commit_info index block_header = - let open Lwt_syntax in - let* context = checkout_exn index block_header.Block_header.shell.context in + let open Lwt_result_syntax in + let context_hash = block_header.Block_header.shell.context in + let* context = + let*! r = checkout index context_hash in + match r with + | Some c -> return c + | None -> tzfail (Cannot_retrieve_commit_info context_hash) + in let irmin_info = Dumpable_context.context_info context in let author = Info.author irmin_info in let message = Info.message irmin_info in let timestamp = Time.Protocol.of_seconds (Info.date irmin_info) in - let* protocol_hash = get_protocol context in - let* test_chain_status = get_test_chain context in - let* predecessor_block_metadata_hash = + let*! protocol_hash = get_protocol context in + let*! test_chain_status = get_test_chain context in + let*! predecessor_block_metadata_hash = find_predecessor_block_metadata_hash context in - let* predecessor_ops_metadata_hash = + let*! predecessor_ops_metadata_hash = find_predecessor_ops_metadata_hash context in - let* data_key = data_node_hash context in + let*! data_key = data_node_hash context in let parents_contexts = Dumpable_context.context_parents context in - return_ok + return ( protocol_hash, author, message, diff --git a/src/lib_context/disk/context.mli b/src/lib_context/disk/context.mli index 9a5f51d595197c61b884de41925e92abcb288931..310c54b6eb2077a0d144f8c6e85e0d3b81173531 100644 --- a/src/lib_context/disk/context.mli +++ b/src/lib_context/disk/context.mli @@ -30,6 +30,7 @@ module type TEZOS_CONTEXT_UNIX = sig type error += | Cannot_create_file of string | Cannot_open_file of string + | Cannot_retrieve_commit_info of Context_hash.t | Cannot_find_protocol | Suspicious_file of int diff --git a/src/lib_context/memory/context.ml b/src/lib_context/memory/context.ml index ca555893941925bf3001f42602e212f68972d2e4..6595170d7d2c6c5ca928600a92da78ba933d65c7 100644 --- a/src/lib_context/memory/context.ml +++ b/src/lib_context/memory/context.ml @@ -202,6 +202,8 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct let+ commit = raw_commit ~time ?message context in Hash.to_context_hash (Store.Commit.hash commit) + let gc _ _ = (* not implemented for in-memory context *) Lwt.return () + (*-- Generic Store Primitives ------------------------------------------------*) let data_key key = current_data_key @ key diff --git a/src/lib_context/sigs/context.ml b/src/lib_context/sigs/context.ml index 3f7d59564fb016607f15e7a83d727a0c23d68f8a..143ce611a8d19ae17d4d4b5375cd0744cd26b08e 100644 --- a/src/lib_context/sigs/context.ml +++ b/src/lib_context/sigs/context.ml @@ -656,6 +656,12 @@ module type TEZOS_CONTEXT = sig val commit : time:Time.Protocol.t -> ?message:string -> context -> Context_hash.t Lwt.t + (** [gc t h] removes from disk all the data older than the commit + [hash]. Every operations working on checkouts greater or equal to + [h] will continue to work. Calling [checkout h'] on GC-ed commits + will return [None]. *) + val gc : index -> Context_hash.t -> unit Lwt.t + val set_head : index -> Chain_id.t -> Context_hash.t -> unit Lwt.t val set_master : index -> Context_hash.t -> unit Lwt.t diff --git a/src/lib_protocol_environment/context_ops/context_ops.ml b/src/lib_protocol_environment/context_ops/context_ops.ml index 4b06a772024ef61194c3d0c2e93f5f5257569c3e..4e44e05d5956bac8245f8a5c62e7df03f1fb796e 100644 --- a/src/lib_protocol_environment/context_ops/context_ops.ml +++ b/src/lib_protocol_environment/context_ops/context_ops.ml @@ -198,6 +198,11 @@ let commit ~time ?message (context : Environment_context.t) = | Context t -> err_implementation_mismatch ~expected:"shell or memory" ~got:t.impl_name +let gc context_index context_hash = + match context_index with + | Disk_index index -> Context.gc index context_hash + | Memory_index index -> Tezos_context_memory.Context.gc index context_hash + let commit_test_chain_genesis (context : Environment_context.t) block_header = match context with | Context {kind = Shell_context.Context; ctxt; _} -> diff --git a/src/lib_shell/block_directory.ml b/src/lib_shell/block_directory.ml index 58cdead10ce1a6e3b0d5789c6882c2a423ca8b2a..ba19794d0fc268b7676af4f008da0b5898e7741e 100644 --- a/src/lib_shell/block_directory.ml +++ b/src/lib_shell/block_directory.ml @@ -518,25 +518,31 @@ let build_raw_rpc_directory (module Proto : Block_services.PROTO) let depth = Option.value ~default:max_int q#depth in (* [depth] is defined as a [uint] not an [int] *) assert (depth >= 0) ; - let* context = Store.Block.context chain_store block in - let*! mem = Context_ops.mem context path in - let*! dir_mem = Context_ops.mem_tree context path in - if not (mem || dir_mem) then Lwt.fail Not_found - else - let*! v = read_partial_context context path depth in - Lwt.return_ok v) ; + let*! _, savepoint_level = Store.Chain.savepoint chain_store in + if Store.Block.level block >= savepoint_level then + let* context = Store.Block.context chain_store block in + let*! mem = Context_ops.mem context path in + let*! dir_mem = Context_ops.mem_tree context path in + if not (mem || dir_mem) then Lwt.fail Not_found + else + let*! v = read_partial_context context path depth in + Lwt.return_ok v + else Lwt.fail Not_found) ; register1 S.Context.merkle_tree (fun (chain_store, block) path query () -> - let*! o = Store.Block.context_opt chain_store block in - match o with - | None -> return None - | Some context -> - let holey = Option.value ~default:false query#holey in - let leaf_kind = - let open Tezos_shell_services.Block_services in - if holey then Hole else Raw_context - in - let*! v = Context_ops.merkle_tree context leaf_kind path in - return_some v) ; + let*! _, savepoint_level = Store.Chain.savepoint chain_store in + if Store.Block.level block >= savepoint_level then + let*! o = Store.Block.context_opt chain_store block in + match o with + | None -> return None + | Some context -> + let holey = Option.value ~default:false query#holey in + let leaf_kind = + let open Tezos_shell_services.Block_services in + if holey then Hole else Raw_context + in + let*! v = Context_ops.merkle_tree context leaf_kind path in + return_some v + else Lwt.fail Not_found) ; (* info *) register0 S.info (fun (chain_store, block) q () -> let chain_id = Store.Chain.chain_id chain_store in diff --git a/src/lib_shell/block_validator.ml b/src/lib_shell/block_validator.ml index 3b66fea09b6f4d178b8e0c45c205f9d90036d02c..208638ebe6f5a05101cf16c54391ea166b7e9fb9 100644 --- a/src/lib_shell/block_validator.ml +++ b/src/lib_shell/block_validator.ml @@ -564,6 +564,10 @@ let preapply w ?canceler chain_store ~predecessor ~timestamp ~protocol_data (* validation cases *) assert false +let unload_context w context_hash = + let bv = Worker.state w in + Block_validator_process.unload bv.validation_process context_hash + let fetch_and_compile_protocol w = let bv = Worker.state w in Protocol_validator.fetch_and_compile_protocol bv.protocol_validator diff --git a/src/lib_shell/block_validator.mli b/src/lib_shell/block_validator.mli index 5e101e92cd42e4265321c47e483346f51fdd780a..19a5aaa53935ce1c6e602200bb606eb385c820fe 100644 --- a/src/lib_shell/block_validator.mli +++ b/src/lib_shell/block_validator.mli @@ -137,6 +137,13 @@ val fetch_and_compile_protocol : Protocol_hash.t -> Registered_protocol.t tzresult Lwt.t +(** [unload bv chain_store context_hash] moves the all the contexts + below the give [context_hash] from the upper layer to the lower + layer. For full and rolling nodes, this is considered as a garbage + collection. *) +val unload_context : + t -> Store.chain_store -> Context_hash.t -> unit tzresult Lwt.t + val shutdown : t -> unit Lwt.t val running_worker : unit -> t diff --git a/src/lib_shell/block_validator_process.ml b/src/lib_shell/block_validator_process.ml index 95102f71146cfdaa90222e778020bb08fd2e5355..4fd3996af353aa6d3292bf6183b4593667bb872a 100644 --- a/src/lib_shell/block_validator_process.ml +++ b/src/lib_shell/block_validator_process.ml @@ -82,6 +82,8 @@ module type S = sig Operation.t trace trace -> unit tzresult Lwt.t + val unload : t -> Store.chain_store -> Context_hash.t -> unit tzresult Lwt.t + val commit_genesis : t -> chain_id:Chain_id.t -> Context_hash.t tzresult Lwt.t (** [init_test_chain] must only be called on a forking block. *) @@ -335,6 +337,14 @@ module Internal_validator_process = struct header operations + let unload _validator chain_store context_hash = + let open Lwt_result_syntax in + let context_index = + Store.context_index (Store.Chain.global_store chain_store) + in + let*! () = Context_ops.gc context_index context_hash in + return_unit + let commit_genesis validator ~chain_id = let context_index = get_context_index validator.chain_store in let genesis = Store.Chain.genesis validator.chain_store in @@ -800,6 +810,10 @@ module External_validator_process = struct in send_request validator request Data_encoding.unit + let unload validator _chain_store context_hash = + let request = External_validation.Unload {context_hash} in + send_request validator request Data_encoding.unit + let commit_genesis validator ~chain_id = let request = External_validation.Commit_genesis {chain_id} in send_request validator request Context_hash.encoding @@ -938,6 +952,10 @@ let precheck_block (E {validator_process = (module VP); validator}) chain_store ~predecessor header operations = VP.precheck_block validator chain_store ~predecessor header operations +let unload (E {validator_process = (module VP); validator}) chain_store + context_hash = + VP.unload validator chain_store context_hash + let commit_genesis (E {validator_process = (module VP); validator}) ~chain_id = VP.commit_genesis validator ~chain_id diff --git a/src/lib_shell/block_validator_process.mli b/src/lib_shell/block_validator_process.mli index a726e5d705efa57ec17dc17aa964bd4c4de684cc..327a4536646bd690b2cbaf9260dddc28dd838f59 100644 --- a/src/lib_shell/block_validator_process.mli +++ b/src/lib_shell/block_validator_process.mli @@ -100,6 +100,12 @@ val precheck_block : Operation.t trace trace -> unit tzresult Lwt.t +(** [unload bvp chain_store context_hash] moves the all the contexts + below the give [context_hash] from the upper layer to the lower + layer. For full and rolling nodes, this is considered as a garbage + collection. *) +val unload : t -> Store.chain_store -> Context_hash.t -> unit tzresult Lwt.t + val commit_genesis : t -> chain_id:Chain_id.t -> Context_hash.t tzresult Lwt.t (** [init_test_chain] must only be called on a forking block. *) diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index c2461a44d326675140d267f528f2f02c1b113727..764fc29aaf987804dec8678436c074411dfcad85 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -435,6 +435,16 @@ let may_flush_or_update_prevalidator parameters event prevalidator chain_db live_blocks live_operations +let may_unload_context w chain_store block_hash = + let open Lwt_result_syntax in + let* b = Store.Block.read_block chain_store block_hash in + let savepoint_context_hash = Store.Block.context_hash b in + let nv = Worker.state w in + Block_validator.unload_context + nv.parameters.block_validator + chain_store + savepoint_context_hash + let on_validation_request w peer start_testchain active_chains spawn_child block = let open Lwt_result_syntax in @@ -454,7 +464,12 @@ let on_validation_request w peer start_testchain active_chains spawn_child block let accepted_head = Fitness.(new_fitness > head_fitness) in if not accepted_head then return Event.Ignored_head else - let* o = Store.Chain.set_head chain_store block in + let* o = + Store.Chain.set_head + ~trigger_gc_callback:(may_unload_context w chain_store) + chain_store + block + in match o with | None -> (* None means that the given head is below a new_head and diff --git a/src/lib_store/shared/store_events.ml b/src/lib_store/shared/store_events.ml index 7a0fc7c9e43907de3ae23073abfbaa553311dac0..bf8bc2fcd5c0083929e1c75a307fb282c56982a4 100644 --- a/src/lib_store/shared/store_events.ml +++ b/src/lib_store/shared/store_events.ml @@ -211,6 +211,15 @@ let end_merging_stores = ~pp1:Time.System.Span.pp_hum ("time", Time.System.Span.encoding) +let start_context_gc = + declare_1 + ~section + ~level:Notice + ~name:"" + ~msg:"running context garbage collection up to level {lafl}" + ~pp1:pp_int32 + ("lafl", Data_encoding.int32) + let try_waiting_for_merge_termination = declare_0 ~section diff --git a/src/lib_store/store.mli b/src/lib_store/store.mli index da6564c5e7571a7ccd00980969ca57f33cb034f2..621340651a5e9cb981f47628c113c0b19682d436 100644 --- a/src/lib_store/store.mli +++ b/src/lib_store/store.mli @@ -733,16 +733,17 @@ module Chain : sig block:Block.t -> (Block_hash.Set.t * Operation_hash.Set.t) tzresult Lwt.t - (** [set_head chain_store block] promotes the [block] as head of the - [chain_store] and triggers an asynchronous store merge if a - cycle is ready to be cemented. Triggering a merge will update - the savepoint, checkpoint and caboose consistently with the - [chain_store]'s history mode. This function returns the previous - head or [None] if the given [block] is below one of the current - known heads. If [block] belongs to a new branch, the previous - head will also be stored as an alternate head. Setting a new - head will fail when the block is not fit to be promoted as head: - too old or no metadata. + (** [set_head ?trigger_gc_callback chain_store block] promotes the + [block] as head of the [chain_store] and triggers an + asynchronous store merge if a cycle is ready to be + cemented. Triggering a merge will update the savepoint, + checkpoint and caboose consistently with the [chain_store]'s + history mode. This function returns the previous head or [None] + if the given [block] is below one of the current known heads. If + [block] belongs to a new branch, the previous head will also be + stored as an alternate head. Setting a new head will fail when + the block is not fit to be promoted as head: too old or no + metadata. After a merge: @@ -760,6 +761,9 @@ module Chain : sig Note: lafl(new_head) is the last allowed fork level of the new head. + [trigger_gc_callback] is a callback to the context's GC. It is + called, if needed, depending on the history mode. + {b Warnings:} - We expect blocks to be sequentially promoted as head using @@ -767,7 +771,11 @@ module Chain : sig - If a merge is triggered while another is happening, this function will block until the first merge is resolved. *) - val set_head : chain_store -> Block.t -> Block.t option tzresult Lwt.t + val set_head : + ?trigger_gc_callback:(Block_hash.t -> unit tzresult Lwt.t) -> + chain_store -> + Block.t -> + Block.t option tzresult Lwt.t (** [known_heads chain_store] returns the list of alternate heads for [chain_store]. *) diff --git a/src/lib_store/unix/block_store.ml b/src/lib_store/unix/block_store.ml index de6706e09b774915f4da2b949c25dc82b2449c99..863c7df8cc2cead78463a161e294e3075eb329d1 100644 --- a/src/lib_store/unix/block_store.ml +++ b/src/lib_store/unix/block_store.ml @@ -1208,9 +1208,9 @@ let create_merging_thread block_store ~history_mode ~old_ro_store ~old_rw_store in return (new_ro_store, new_savepoint, new_caboose) -let merge_stores block_store ~(on_error : tztrace -> unit tzresult Lwt.t) - ~finalizer ~history_mode ~new_head ~new_head_metadata - ~cementing_highwatermark = +let merge_stores ?trigger_gc_callback block_store + ~(on_error : tztrace -> unit tzresult Lwt.t) ~finalizer ~history_mode + ~new_head ~new_head_metadata ~cementing_highwatermark = let open Lwt_result_syntax in let* () = fail_when block_store.readonly Cannot_write_in_readonly in (* Do not allow multiple merges: force waiting for a potential @@ -1297,6 +1297,19 @@ let merge_stores block_store ~(on_error : tztrace -> unit tzresult Lwt.t) section, in case it needs to access the block store. *) let* () = finalizer new_head_lafl in + (* We can now trigger the context GC *) + let* () = + if not History_mode.(equal history_mode Archive) then + match trigger_gc_callback with + | None -> return_unit + | Some f -> + let*! () = + Store_events.( + emit start_context_gc new_head_lafl) + in + f (fst new_savepoint) + else return_unit + in (* The merge operation succeeded, the store is now idle. *) block_store.merging_thread <- None ; let* () = write_status block_store Idle in diff --git a/src/lib_store/unix/block_store.mli b/src/lib_store/unix/block_store.mli index 5f5df3ab2c77daf340f40cc4641ec25268059c1c..930e0f09eede2f3383c2d609b2404077ea304f54 100644 --- a/src/lib_store/unix/block_store.mli +++ b/src/lib_store/unix/block_store.mli @@ -289,6 +289,7 @@ val await_merging : block_store -> unit Lwt.t in concurrent intertwining causing the cementing to be out of order. *) val merge_stores : + ?trigger_gc_callback:(Block_hash.t -> unit tzresult Lwt.t) -> block_store -> on_error:(tztrace -> unit tzresult Lwt.t) -> finalizer:(int32 -> unit tzresult Lwt.t) -> diff --git a/src/lib_store/unix/store.ml b/src/lib_store/unix/store.ml index ce488e3bb24d90fcd2a5505471a9122c4f642da9..43b3b642e3232958bad46d07d638415511625715 100644 --- a/src/lib_store/unix/store.ml +++ b/src/lib_store/unix/store.ml @@ -1344,7 +1344,7 @@ module Chain = struct (Int.to_float (List.length new_alternate_heads)) ; return_unit - let set_head chain_store new_head = + let set_head ?trigger_gc_callback chain_store new_head = let open Lwt_result_syntax in Shared.update_with chain_store.chain_state (fun chain_state -> (* The merge cannot finish until we release the lock on the @@ -1483,6 +1483,7 @@ module Chain = struct done so this call is expected to return quickly. *) let* () = Block_store.merge_stores + ?trigger_gc_callback chain_store.block_store ~on_error ~finalizer diff --git a/src/lib_store/unix/store.mli b/src/lib_store/unix/store.mli index 3b40d119e0e3e5e1d5f9363934826bf2703d7e28..f080584ae5aa6f1204da06fc27c23f06cf770985 100644 --- a/src/lib_store/unix/store.mli +++ b/src/lib_store/unix/store.mli @@ -733,16 +733,17 @@ module Chain : sig block:Block.t -> (Block_hash.Set.t * Operation_hash.Set.t) tzresult Lwt.t - (** [set_head chain_store block] promotes the [block] as head of the - [chain_store] and triggers an asynchronous store merge if a - cycle is ready to be cemented. Triggering a merge will update - the savepoint, checkpoint and caboose consistently with the - [chain_store]'s history mode. This function returns the previous - head or [None] if the given [block] is below one of the current - known heads. If [block] belongs to a new branch, the previous - head will also be stored as an alternate head. Setting a new - head will fail when the block is not fit to be promoted as head: - too old or no metadata. + (** [set_head ?trigger_gc_callback chain_store block] promotes the + [block] as head of the [chain_store] and triggers an + asynchronous store merge if a cycle is ready to be + cemented. Triggering a merge will update the savepoint, + checkpoint and caboose consistently with the [chain_store]'s + history mode. This function returns the previous head or [None] + if the given [block] is below one of the current known heads. If + [block] belongs to a new branch, the previous head will also be + stored as an alternate head. Setting a new head will fail when + the block is not fit to be promoted as head: too old or no + metadata. After a merge: @@ -760,6 +761,9 @@ module Chain : sig Note: lafl(new_head) is the last allowed fork level of the new head. + [trigger_gc_callback] is a callback to the context's GC. It is + called, if needed, depending on the history mode. + {b Warnings:} - We expect blocks to be sequentially promoted as head using @@ -767,7 +771,11 @@ module Chain : sig - If a merge is triggered while another is happening, this function will block until the first merge is resolved. *) - val set_head : chain_store -> Block.t -> Block.t option tzresult Lwt.t + val set_head : + ?trigger_gc_callback:(Block_hash.t -> unit tzresult Lwt.t) -> + chain_store -> + Block.t -> + Block.t option tzresult Lwt.t (** [known_heads chain_store] returns the list of alternate heads for [chain_store]. *) diff --git a/src/lib_validation/external_validation.ml b/src/lib_validation/external_validation.ml index f31d0bcfe3a8e22e835677292f69fad95f1cacc4..e020f8de5349f64b0fc547b7d22891a62813bd7d 100644 --- a/src/lib_validation/external_validation.ml +++ b/src/lib_validation/external_validation.ml @@ -74,6 +74,7 @@ type request = context_hash : Context_hash.t; forked_header : Block_header.t; } + | Unload of {context_hash : Context_hash.t} | Terminate | Reconfigure_event_logging of Tezos_base_unix.Internal_event_unix.Configuration.t @@ -111,6 +112,12 @@ let request_pp ppf = function Block_hash.pp_short (Block_header.hash forked_header) | Terminate -> Format.fprintf ppf "terminate validation process" + | Unload {context_hash} -> + Format.fprintf + ppf + "unloading context below %a" + Context_hash.pp + context_hash | Reconfigure_event_logging _ -> Format.fprintf ppf "reconfigure event logging" @@ -333,6 +340,15 @@ let case_precheck tag = hash; }) +let case_unload tag = + let open Data_encoding in + case + tag + ~title:"unload" + (obj1 (req "context_hash" Context_hash.encoding)) + (function Unload {context_hash} -> Some context_hash | _ -> None) + (fun context_hash -> Unload {context_hash}) + let request_encoding = let open Data_encoding in union @@ -378,6 +394,7 @@ let request_encoding = (fun c -> Reconfigure_event_logging c); case_preapply (Tag 7); case_precheck (Tag 8); + case_unload (Tag 9); ] let send pin encoding data = diff --git a/src/lib_validation/external_validation.mli b/src/lib_validation/external_validation.mli index 4fd1ccd55fdf5a1a301afa169c0e8ab24831a91d..44d9a86f129b0446e003b457b15c45dd311ca6aa 100644 --- a/src/lib_validation/external_validation.mli +++ b/src/lib_validation/external_validation.mli @@ -74,6 +74,7 @@ type request = context_hash : Context_hash.t; forked_header : Block_header.t; } + | Unload of {context_hash : Context_hash.t} | Terminate | Reconfigure_event_logging of Tezos_base_unix.Internal_event_unix.Configuration.t diff --git a/vendors/irmin/.git_back/HEAD b/vendors/irmin/.git_back/HEAD new file mode 100644 index 0000000000000000000000000000000000000000..79c8d308dd881b2cfa9b340461b33f63858850a3 --- /dev/null +++ b/vendors/irmin/.git_back/HEAD @@ -0,0 +1 @@ +ref: refs/heads/3.4 diff --git a/vendors/irmin/.git_back/config b/vendors/irmin/.git_back/config new file mode 100644 index 0000000000000000000000000000000000000000..83dff30c664530ce8fe0909aceff84969d293a33 --- /dev/null +++ b/vendors/irmin/.git_back/config @@ -0,0 +1,14 @@ +[core] + repositoryformatversion = 0 + filemode = true + bare = false + logallrefupdates = true +[remote "origin"] + url = https://github.com/mirage/irmin + fetch = +refs/heads/*:refs/remotes/origin/* +[branch "main"] + remote = origin + merge = refs/heads/main +[branch "3.4"] + remote = origin + merge = refs/heads/3.4 diff --git a/vendors/irmin/.git_back/description b/vendors/irmin/.git_back/description new file mode 100644 index 0000000000000000000000000000000000000000..498b267a8c7812490d6479839c5577eaaec79d62 --- /dev/null +++ b/vendors/irmin/.git_back/description @@ -0,0 +1 @@ +Unnamed repository; edit this file 'description' to name the repository. diff --git a/vendors/irmin/.git_back/hooks/applypatch-msg.sample b/vendors/irmin/.git_back/hooks/applypatch-msg.sample new file mode 100755 index 0000000000000000000000000000000000000000..a5d7b84a673458d14d9aab082183a1968c2c7492 --- /dev/null +++ b/vendors/irmin/.git_back/hooks/applypatch-msg.sample @@ -0,0 +1,15 @@ +#!/bin/sh +# +# An example hook script to check the commit log message taken by +# applypatch from an e-mail message. +# +# The hook should exit with non-zero status after issuing an +# appropriate message if it wants to stop the commit. The hook is +# allowed to edit the commit message file. +# +# To enable this hook, rename this file to "applypatch-msg". + +. git-sh-setup +commitmsg="$(git rev-parse --git-path hooks/commit-msg)" +test -x "$commitmsg" && exec "$commitmsg" ${1+"$@"} +: diff --git a/vendors/irmin/.git_back/hooks/commit-msg.sample b/vendors/irmin/.git_back/hooks/commit-msg.sample new file mode 100755 index 0000000000000000000000000000000000000000..b58d1184a9d43a39c0d95f32453efc78581877d6 --- /dev/null +++ b/vendors/irmin/.git_back/hooks/commit-msg.sample @@ -0,0 +1,24 @@ +#!/bin/sh +# +# An example hook script to check the commit log message. +# Called by "git commit" with one argument, the name of the file +# that has the commit message. The hook should exit with non-zero +# status after issuing an appropriate message if it wants to stop the +# commit. The hook is allowed to edit the commit message file. +# +# To enable this hook, rename this file to "commit-msg". + +# Uncomment the below to add a Signed-off-by line to the message. +# Doing this in a hook is a bad idea in general, but the prepare-commit-msg +# hook is more suited to it. +# +# SOB=$(git var GIT_AUTHOR_IDENT | sed -n 's/^\(.*>\).*$/Signed-off-by: \1/p') +# grep -qs "^$SOB" "$1" || echo "$SOB" >> "$1" + +# This example catches duplicate Signed-off-by lines. + +test "" = "$(grep '^Signed-off-by: ' "$1" | + sort | uniq -c | sed -e '/^[ ]*1[ ]/d')" || { + echo >&2 Duplicate Signed-off-by lines. + exit 1 +} diff --git a/vendors/irmin/.git_back/hooks/fsmonitor-watchman.sample b/vendors/irmin/.git_back/hooks/fsmonitor-watchman.sample new file mode 100755 index 0000000000000000000000000000000000000000..14ed0aa42de0f291c0f696922110e70544c3dae2 --- /dev/null +++ b/vendors/irmin/.git_back/hooks/fsmonitor-watchman.sample @@ -0,0 +1,173 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use IPC::Open2; + +# An example hook script to integrate Watchman +# (https://facebook.github.io/watchman/) with git to speed up detecting +# new and modified files. +# +# The hook is passed a version (currently 2) and last update token +# formatted as a string and outputs to stdout a new update token and +# all files that have been modified since the update token. Paths must +# be relative to the root of the working tree and separated by a single NUL. +# +# To enable this hook, rename this file to "query-watchman" and set +# 'git config core.fsmonitor .git/hooks/query-watchman' +# +my ($version, $last_update_token) = @ARGV; + +# Uncomment for debugging +# print STDERR "$0 $version $last_update_token\n"; + +# Check the hook interface version +if ($version ne 2) { + die "Unsupported query-fsmonitor hook version '$version'.\n" . + "Falling back to scanning...\n"; +} + +my $git_work_tree = get_working_dir(); + +my $retry = 1; + +my $json_pkg; +eval { + require JSON::XS; + $json_pkg = "JSON::XS"; + 1; +} or do { + require JSON::PP; + $json_pkg = "JSON::PP"; +}; + +launch_watchman(); + +sub launch_watchman { + my $o = watchman_query(); + if (is_work_tree_watched($o)) { + output_result($o->{clock}, @{$o->{files}}); + } +} + +sub output_result { + my ($clockid, @files) = @_; + + # Uncomment for debugging watchman output + # open (my $fh, ">", ".git/watchman-output.out"); + # binmode $fh, ":utf8"; + # print $fh "$clockid\n@files\n"; + # close $fh; + + binmode STDOUT, ":utf8"; + print $clockid; + print "\0"; + local $, = "\0"; + print @files; +} + +sub watchman_clock { + my $response = qx/watchman clock "$git_work_tree"/; + die "Failed to get clock id on '$git_work_tree'.\n" . + "Falling back to scanning...\n" if $? != 0; + + return $json_pkg->new->utf8->decode($response); +} + +sub watchman_query { + my $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'watchman -j --no-pretty') + or die "open2() failed: $!\n" . + "Falling back to scanning...\n"; + + # In the query expression below we're asking for names of files that + # changed since $last_update_token but not from the .git folder. + # + # To accomplish this, we're using the "since" generator to use the + # recency index to select candidate nodes and "fields" to limit the + # output to file names only. Then we're using the "expression" term to + # further constrain the results. + if (substr($last_update_token, 0, 1) eq "c") { + $last_update_token = "\"$last_update_token\""; + } + my $query = <<" END"; + ["query", "$git_work_tree", { + "since": $last_update_token, + "fields": ["name"], + "expression": ["not", ["dirname", ".git"]] + }] + END + + # Uncomment for debugging the watchman query + # open (my $fh, ">", ".git/watchman-query.json"); + # print $fh $query; + # close $fh; + + print CHLD_IN $query; + close CHLD_IN; + my $response = do {local $/; }; + + # Uncomment for debugging the watch response + # open ($fh, ">", ".git/watchman-response.json"); + # print $fh $response; + # close $fh; + + die "Watchman: command returned no output.\n" . + "Falling back to scanning...\n" if $response eq ""; + die "Watchman: command returned invalid output: $response\n" . + "Falling back to scanning...\n" unless $response =~ /^\{/; + + return $json_pkg->new->utf8->decode($response); +} + +sub is_work_tree_watched { + my ($output) = @_; + my $error = $output->{error}; + if ($retry > 0 and $error and $error =~ m/unable to resolve root .* directory (.*) is not watched/) { + $retry--; + my $response = qx/watchman watch "$git_work_tree"/; + die "Failed to make watchman watch '$git_work_tree'.\n" . + "Falling back to scanning...\n" if $? != 0; + $output = $json_pkg->new->utf8->decode($response); + $error = $output->{error}; + die "Watchman: $error.\n" . + "Falling back to scanning...\n" if $error; + + # Uncomment for debugging watchman output + # open (my $fh, ">", ".git/watchman-output.out"); + # close $fh; + + # Watchman will always return all files on the first query so + # return the fast "everything is dirty" flag to git and do the + # Watchman query just to get it over with now so we won't pay + # the cost in git to look up each individual file. + my $o = watchman_clock(); + $error = $output->{error}; + + die "Watchman: $error.\n" . + "Falling back to scanning...\n" if $error; + + output_result($o->{clock}, ("/")); + $last_update_token = $o->{clock}; + + eval { launch_watchman() }; + return 0; + } + + die "Watchman: $error.\n" . + "Falling back to scanning...\n" if $error; + + return 1; +} + +sub get_working_dir { + my $working_dir; + if ($^O =~ 'msys' || $^O =~ 'cygwin') { + $working_dir = Win32::GetCwd(); + $working_dir =~ tr/\\/\//; + } else { + require Cwd; + $working_dir = Cwd::cwd(); + } + + return $working_dir; +} diff --git a/vendors/irmin/.git_back/hooks/post-update.sample b/vendors/irmin/.git_back/hooks/post-update.sample new file mode 100755 index 0000000000000000000000000000000000000000..ec17ec1939b7c3e86b7cb6c0c4de6b0818a7e75e --- /dev/null +++ b/vendors/irmin/.git_back/hooks/post-update.sample @@ -0,0 +1,8 @@ +#!/bin/sh +# +# An example hook script to prepare a packed repository for use over +# dumb transports. +# +# To enable this hook, rename this file to "post-update". + +exec git update-server-info diff --git a/vendors/irmin/.git_back/hooks/pre-applypatch.sample b/vendors/irmin/.git_back/hooks/pre-applypatch.sample new file mode 100755 index 0000000000000000000000000000000000000000..4142082bcb939bbc17985a69ba748491ac6b62a5 --- /dev/null +++ b/vendors/irmin/.git_back/hooks/pre-applypatch.sample @@ -0,0 +1,14 @@ +#!/bin/sh +# +# An example hook script to verify what is about to be committed +# by applypatch from an e-mail message. +# +# The hook should exit with non-zero status after issuing an +# appropriate message if it wants to stop the commit. +# +# To enable this hook, rename this file to "pre-applypatch". + +. git-sh-setup +precommit="$(git rev-parse --git-path hooks/pre-commit)" +test -x "$precommit" && exec "$precommit" ${1+"$@"} +: diff --git a/vendors/irmin/.git_back/hooks/pre-commit.sample b/vendors/irmin/.git_back/hooks/pre-commit.sample new file mode 100755 index 0000000000000000000000000000000000000000..e144712c85c055bcf3248ab342592b440a477062 --- /dev/null +++ b/vendors/irmin/.git_back/hooks/pre-commit.sample @@ -0,0 +1,49 @@ +#!/bin/sh +# +# An example hook script to verify what is about to be committed. +# Called by "git commit" with no arguments. The hook should +# exit with non-zero status after issuing an appropriate message if +# it wants to stop the commit. +# +# To enable this hook, rename this file to "pre-commit". + +if git rev-parse --verify HEAD >/dev/null 2>&1 +then + against=HEAD +else + # Initial commit: diff against an empty tree object + against=$(git hash-object -t tree /dev/null) +fi + +# If you want to allow non-ASCII filenames set this variable to true. +allownonascii=$(git config --type=bool hooks.allownonascii) + +# Redirect output to stderr. +exec 1>&2 + +# Cross platform projects tend to avoid non-ASCII filenames; prevent +# them from being added to the repository. We exploit the fact that the +# printable range starts at the space character and ends with tilde. +if [ "$allownonascii" != "true" ] && + # Note that the use of brackets around a tr range is ok here, (it's + # even required, for portability to Solaris 10's /usr/bin/tr), since + # the square bracket bytes happen to fall in the designated range. + test $(git diff --cached --name-only --diff-filter=A -z $against | + LC_ALL=C tr -d '[ -~]\0' | wc -c) != 0 +then + cat <<\EOF +Error: Attempt to add a non-ASCII file name. + +This can cause problems if you want to work with people on other platforms. + +To be portable it is advisable to rename the file. + +If you know what you are doing you can disable this check using: + + git config hooks.allownonascii true +EOF + exit 1 +fi + +# If there are whitespace errors, print the offending file names and fail. +exec git diff-index --check --cached $against -- diff --git a/vendors/irmin/.git_back/hooks/pre-merge-commit.sample b/vendors/irmin/.git_back/hooks/pre-merge-commit.sample new file mode 100755 index 0000000000000000000000000000000000000000..399eab1924e39da570b389b0bef1ca713b3b05c3 --- /dev/null +++ b/vendors/irmin/.git_back/hooks/pre-merge-commit.sample @@ -0,0 +1,13 @@ +#!/bin/sh +# +# An example hook script to verify what is about to be committed. +# Called by "git merge" with no arguments. The hook should +# exit with non-zero status after issuing an appropriate message to +# stderr if it wants to stop the merge commit. +# +# To enable this hook, rename this file to "pre-merge-commit". + +. git-sh-setup +test -x "$GIT_DIR/hooks/pre-commit" && + exec "$GIT_DIR/hooks/pre-commit" +: diff --git a/vendors/irmin/.git_back/hooks/pre-push.sample b/vendors/irmin/.git_back/hooks/pre-push.sample new file mode 100755 index 0000000000000000000000000000000000000000..4ce688d32b7532862767345f2b991ae856f7d4a8 --- /dev/null +++ b/vendors/irmin/.git_back/hooks/pre-push.sample @@ -0,0 +1,53 @@ +#!/bin/sh + +# An example hook script to verify what is about to be pushed. Called by "git +# push" after it has checked the remote status, but before anything has been +# pushed. If this script exits with a non-zero status nothing will be pushed. +# +# This hook is called with the following parameters: +# +# $1 -- Name of the remote to which the push is being done +# $2 -- URL to which the push is being done +# +# If pushing without using a named remote those arguments will be equal. +# +# Information about the commits which are being pushed is supplied as lines to +# the standard input in the form: +# +# +# +# This sample shows how to prevent push of commits where the log message starts +# with "WIP" (work in progress). + +remote="$1" +url="$2" + +zero=$(git hash-object --stdin &2 "Found WIP commit in $local_ref, not pushing" + exit 1 + fi + fi +done + +exit 0 diff --git a/vendors/irmin/.git_back/hooks/pre-rebase.sample b/vendors/irmin/.git_back/hooks/pre-rebase.sample new file mode 100755 index 0000000000000000000000000000000000000000..6cbef5c370d8c3486ca85423dd70440c5e0a2aa2 --- /dev/null +++ b/vendors/irmin/.git_back/hooks/pre-rebase.sample @@ -0,0 +1,169 @@ +#!/bin/sh +# +# Copyright (c) 2006, 2008 Junio C Hamano +# +# The "pre-rebase" hook is run just before "git rebase" starts doing +# its job, and can prevent the command from running by exiting with +# non-zero status. +# +# The hook is called with the following parameters: +# +# $1 -- the upstream the series was forked from. +# $2 -- the branch being rebased (or empty when rebasing the current branch). +# +# This sample shows how to prevent topic branches that are already +# merged to 'next' branch from getting rebased, because allowing it +# would result in rebasing already published history. + +publish=next +basebranch="$1" +if test "$#" = 2 +then + topic="refs/heads/$2" +else + topic=`git symbolic-ref HEAD` || + exit 0 ;# we do not interrupt rebasing detached HEAD +fi + +case "$topic" in +refs/heads/??/*) + ;; +*) + exit 0 ;# we do not interrupt others. + ;; +esac + +# Now we are dealing with a topic branch being rebased +# on top of master. Is it OK to rebase it? + +# Does the topic really exist? +git show-ref -q "$topic" || { + echo >&2 "No such branch $topic" + exit 1 +} + +# Is topic fully merged to master? +not_in_master=`git rev-list --pretty=oneline ^master "$topic"` +if test -z "$not_in_master" +then + echo >&2 "$topic is fully merged to master; better remove it." + exit 1 ;# we could allow it, but there is no point. +fi + +# Is topic ever merged to next? If so you should not be rebasing it. +only_next_1=`git rev-list ^master "^$topic" ${publish} | sort` +only_next_2=`git rev-list ^master ${publish} | sort` +if test "$only_next_1" = "$only_next_2" +then + not_in_topic=`git rev-list "^$topic" master` + if test -z "$not_in_topic" + then + echo >&2 "$topic is already up to date with master" + exit 1 ;# we could allow it, but there is no point. + else + exit 0 + fi +else + not_in_next=`git rev-list --pretty=oneline ^${publish} "$topic"` + /usr/bin/perl -e ' + my $topic = $ARGV[0]; + my $msg = "* $topic has commits already merged to public branch:\n"; + my (%not_in_next) = map { + /^([0-9a-f]+) /; + ($1 => 1); + } split(/\n/, $ARGV[1]); + for my $elem (map { + /^([0-9a-f]+) (.*)$/; + [$1 => $2]; + } split(/\n/, $ARGV[2])) { + if (!exists $not_in_next{$elem->[0]}) { + if ($msg) { + print STDERR $msg; + undef $msg; + } + print STDERR " $elem->[1]\n"; + } + } + ' "$topic" "$not_in_next" "$not_in_master" + exit 1 +fi + +<<\DOC_END + +This sample hook safeguards topic branches that have been +published from being rewound. + +The workflow assumed here is: + + * Once a topic branch forks from "master", "master" is never + merged into it again (either directly or indirectly). + + * Once a topic branch is fully cooked and merged into "master", + it is deleted. If you need to build on top of it to correct + earlier mistakes, a new topic branch is created by forking at + the tip of the "master". This is not strictly necessary, but + it makes it easier to keep your history simple. + + * Whenever you need to test or publish your changes to topic + branches, merge them into "next" branch. + +The script, being an example, hardcodes the publish branch name +to be "next", but it is trivial to make it configurable via +$GIT_DIR/config mechanism. + +With this workflow, you would want to know: + +(1) ... if a topic branch has ever been merged to "next". Young + topic branches can have stupid mistakes you would rather + clean up before publishing, and things that have not been + merged into other branches can be easily rebased without + affecting other people. But once it is published, you would + not want to rewind it. + +(2) ... if a topic branch has been fully merged to "master". + Then you can delete it. More importantly, you should not + build on top of it -- other people may already want to + change things related to the topic as patches against your + "master", so if you need further changes, it is better to + fork the topic (perhaps with the same name) afresh from the + tip of "master". + +Let's look at this example: + + o---o---o---o---o---o---o---o---o---o "next" + / / / / + / a---a---b A / / + / / / / + / / c---c---c---c B / + / / / \ / + / / / b---b C \ / + / / / / \ / + ---o---o---o---o---o---o---o---o---o---o---o "master" + + +A, B and C are topic branches. + + * A has one fix since it was merged up to "next". + + * B has finished. It has been fully merged up to "master" and "next", + and is ready to be deleted. + + * C has not merged to "next" at all. + +We would want to allow C to be rebased, refuse A, and encourage +B to be deleted. + +To compute (1): + + git rev-list ^master ^topic next + git rev-list ^master next + + if these match, topic has not merged in next at all. + +To compute (2): + + git rev-list master..topic + + if this is empty, it is fully merged to "master". + +DOC_END diff --git a/vendors/irmin/.git_back/hooks/pre-receive.sample b/vendors/irmin/.git_back/hooks/pre-receive.sample new file mode 100755 index 0000000000000000000000000000000000000000..a1fd29ec14823d8bc4a8d1a2cfe35451580f5118 --- /dev/null +++ b/vendors/irmin/.git_back/hooks/pre-receive.sample @@ -0,0 +1,24 @@ +#!/bin/sh +# +# An example hook script to make use of push options. +# The example simply echoes all push options that start with 'echoback=' +# and rejects all pushes when the "reject" push option is used. +# +# To enable this hook, rename this file to "pre-receive". + +if test -n "$GIT_PUSH_OPTION_COUNT" +then + i=0 + while test "$i" -lt "$GIT_PUSH_OPTION_COUNT" + do + eval "value=\$GIT_PUSH_OPTION_$i" + case "$value" in + echoback=*) + echo "echo from the pre-receive-hook: ${value#*=}" >&2 + ;; + reject) + exit 1 + esac + i=$((i + 1)) + done +fi diff --git a/vendors/irmin/.git_back/hooks/prepare-commit-msg.sample b/vendors/irmin/.git_back/hooks/prepare-commit-msg.sample new file mode 100755 index 0000000000000000000000000000000000000000..10fa14c5ab0134436e2ae435138bf921eb477c60 --- /dev/null +++ b/vendors/irmin/.git_back/hooks/prepare-commit-msg.sample @@ -0,0 +1,42 @@ +#!/bin/sh +# +# An example hook script to prepare the commit log message. +# Called by "git commit" with the name of the file that has the +# commit message, followed by the description of the commit +# message's source. The hook's purpose is to edit the commit +# message file. If the hook fails with a non-zero status, +# the commit is aborted. +# +# To enable this hook, rename this file to "prepare-commit-msg". + +# This hook includes three examples. The first one removes the +# "# Please enter the commit message..." help message. +# +# The second includes the output of "git diff --name-status -r" +# into the message, just before the "git status" output. It is +# commented because it doesn't cope with --amend or with squashed +# commits. +# +# The third example adds a Signed-off-by line to the message, that can +# still be edited. This is rarely a good idea. + +COMMIT_MSG_FILE=$1 +COMMIT_SOURCE=$2 +SHA1=$3 + +/usr/bin/perl -i.bak -ne 'print unless(m/^. Please enter the commit message/..m/^#$/)' "$COMMIT_MSG_FILE" + +# case "$COMMIT_SOURCE,$SHA1" in +# ,|template,) +# /usr/bin/perl -i.bak -pe ' +# print "\n" . `git diff --cached --name-status -r` +# if /^#/ && $first++ == 0' "$COMMIT_MSG_FILE" ;; +# *) ;; +# esac + +# SOB=$(git var GIT_COMMITTER_IDENT | sed -n 's/^\(.*>\).*$/Signed-off-by: \1/p') +# git interpret-trailers --in-place --trailer "$SOB" "$COMMIT_MSG_FILE" +# if test -z "$COMMIT_SOURCE" +# then +# /usr/bin/perl -i.bak -pe 'print "\n" if !$first_line++' "$COMMIT_MSG_FILE" +# fi diff --git a/vendors/irmin/.git_back/hooks/push-to-checkout.sample b/vendors/irmin/.git_back/hooks/push-to-checkout.sample new file mode 100755 index 0000000000000000000000000000000000000000..af5a0c0018b5e9c04b56ac52f21b4d28f48d99ea --- /dev/null +++ b/vendors/irmin/.git_back/hooks/push-to-checkout.sample @@ -0,0 +1,78 @@ +#!/bin/sh + +# An example hook script to update a checked-out tree on a git push. +# +# This hook is invoked by git-receive-pack(1) when it reacts to git +# push and updates reference(s) in its repository, and when the push +# tries to update the branch that is currently checked out and the +# receive.denyCurrentBranch configuration variable is set to +# updateInstead. +# +# By default, such a push is refused if the working tree and the index +# of the remote repository has any difference from the currently +# checked out commit; when both the working tree and the index match +# the current commit, they are updated to match the newly pushed tip +# of the branch. This hook is to be used to override the default +# behaviour; however the code below reimplements the default behaviour +# as a starting point for convenient modification. +# +# The hook receives the commit with which the tip of the current +# branch is going to be updated: +commit=$1 + +# It can exit with a non-zero status to refuse the push (when it does +# so, it must not modify the index or the working tree). +die () { + echo >&2 "$*" + exit 1 +} + +# Or it can make any necessary changes to the working tree and to the +# index to bring them to the desired state when the tip of the current +# branch is updated to the new commit, and exit with a zero status. +# +# For example, the hook can simply run git read-tree -u -m HEAD "$1" +# in order to emulate git fetch that is run in the reverse direction +# with git push, as the two-tree form of git read-tree -u -m is +# essentially the same as git switch or git checkout that switches +# branches while keeping the local changes in the working tree that do +# not interfere with the difference between the branches. + +# The below is a more-or-less exact translation to shell of the C code +# for the default behaviour for git's push-to-checkout hook defined in +# the push_to_deploy() function in builtin/receive-pack.c. +# +# Note that the hook will be executed from the repository directory, +# not from the working tree, so if you want to perform operations on +# the working tree, you will have to adapt your code accordingly, e.g. +# by adding "cd .." or using relative paths. + +if ! git update-index -q --ignore-submodules --refresh +then + die "Up-to-date check failed" +fi + +if ! git diff-files --quiet --ignore-submodules -- +then + die "Working directory has unstaged changes" +fi + +# This is a rough translation of: +# +# head_has_history() ? "HEAD" : EMPTY_TREE_SHA1_HEX +if git cat-file -e HEAD 2>/dev/null +then + head=HEAD +else + head=$(git hash-object -t tree --stdin &2 + echo " (if you want, you could supply GIT_DIR then run" >&2 + echo " $0 )" >&2 + exit 1 +fi + +if [ -z "$refname" -o -z "$oldrev" -o -z "$newrev" ]; then + echo "usage: $0 " >&2 + exit 1 +fi + +# --- Config +allowunannotated=$(git config --type=bool hooks.allowunannotated) +allowdeletebranch=$(git config --type=bool hooks.allowdeletebranch) +denycreatebranch=$(git config --type=bool hooks.denycreatebranch) +allowdeletetag=$(git config --type=bool hooks.allowdeletetag) +allowmodifytag=$(git config --type=bool hooks.allowmodifytag) + +# check for no description +projectdesc=$(sed -e '1q' "$GIT_DIR/description") +case "$projectdesc" in +"Unnamed repository"* | "") + echo "*** Project description file hasn't been set" >&2 + exit 1 + ;; +esac + +# --- Check types +# if $newrev is 0000...0000, it's a commit to delete a ref. +zero=$(git hash-object --stdin &2 + echo "*** Use 'git tag [ -a | -s ]' for tags you want to propagate." >&2 + exit 1 + fi + ;; + refs/tags/*,delete) + # delete tag + if [ "$allowdeletetag" != "true" ]; then + echo "*** Deleting a tag is not allowed in this repository" >&2 + exit 1 + fi + ;; + refs/tags/*,tag) + # annotated tag + if [ "$allowmodifytag" != "true" ] && git rev-parse $refname > /dev/null 2>&1 + then + echo "*** Tag '$refname' already exists." >&2 + echo "*** Modifying a tag is not allowed in this repository." >&2 + exit 1 + fi + ;; + refs/heads/*,commit) + # branch + if [ "$oldrev" = "$zero" -a "$denycreatebranch" = "true" ]; then + echo "*** Creating a branch is not allowed in this repository" >&2 + exit 1 + fi + ;; + refs/heads/*,delete) + # delete branch + if [ "$allowdeletebranch" != "true" ]; then + echo "*** Deleting a branch is not allowed in this repository" >&2 + exit 1 + fi + ;; + refs/remotes/*,commit) + # tracking branch + ;; + refs/remotes/*,delete) + # delete tracking branch + if [ "$allowdeletebranch" != "true" ]; then + echo "*** Deleting a tracking branch is not allowed in this repository" >&2 + exit 1 + fi + ;; + *) + # Anything else (is there anything else?) + echo "*** Update hook: unknown type of update to ref $refname of type $newrev_type" >&2 + exit 1 + ;; +esac + +# --- Finished +exit 0 diff --git a/vendors/irmin/.git_back/index b/vendors/irmin/.git_back/index new file mode 100644 index 0000000000000000000000000000000000000000..d756606c7219579104cb7ae44a1e0ffc812cf3b0 Binary files /dev/null and b/vendors/irmin/.git_back/index differ diff --git a/vendors/irmin/.git_back/info/exclude b/vendors/irmin/.git_back/info/exclude new file mode 100644 index 0000000000000000000000000000000000000000..a5196d1be8fb59edf8062bef36d3a602e0812139 --- /dev/null +++ b/vendors/irmin/.git_back/info/exclude @@ -0,0 +1,6 @@ +# git ls-files --others --exclude-from=.git/info/exclude +# Lines that start with '#' are comments. +# For a project mostly in C, the following would be a good set of +# exclude patterns (uncomment them if you want to use them): +# *.[oa] +# *~ diff --git a/vendors/irmin/.git_back/logs/HEAD b/vendors/irmin/.git_back/logs/HEAD new file mode 100644 index 0000000000000000000000000000000000000000..2bedec0424972635d3fbad16359dce443f25ed5e --- /dev/null +++ b/vendors/irmin/.git_back/logs/HEAD @@ -0,0 +1,2 @@ +0000000000000000000000000000000000000000 df93d50134aad5e6c8fe766a47c044e89cd051df vicall 1657266479 +0200 clone: from https://github.com/mirage/irmin +df93d50134aad5e6c8fe766a47c044e89cd051df df93d50134aad5e6c8fe766a47c044e89cd051df vicall 1657266482 +0200 checkout: moving from main to 3.4 diff --git a/vendors/irmin/.git_back/logs/refs/heads/3.4 b/vendors/irmin/.git_back/logs/refs/heads/3.4 new file mode 100644 index 0000000000000000000000000000000000000000..0a1c74a24e83c8873a7ba6812d67e14508411978 --- /dev/null +++ b/vendors/irmin/.git_back/logs/refs/heads/3.4 @@ -0,0 +1 @@ +0000000000000000000000000000000000000000 df93d50134aad5e6c8fe766a47c044e89cd051df vicall 1657266482 +0200 branch: Created from refs/remotes/origin/3.4 diff --git a/vendors/irmin/.git_back/logs/refs/heads/main b/vendors/irmin/.git_back/logs/refs/heads/main new file mode 100644 index 0000000000000000000000000000000000000000..cc8b805109083df88d06e7acbb36f4233f663645 --- /dev/null +++ b/vendors/irmin/.git_back/logs/refs/heads/main @@ -0,0 +1 @@ +0000000000000000000000000000000000000000 df93d50134aad5e6c8fe766a47c044e89cd051df vicall 1657266479 +0200 clone: from https://github.com/mirage/irmin diff --git a/vendors/irmin/.git_back/logs/refs/remotes/origin/HEAD b/vendors/irmin/.git_back/logs/refs/remotes/origin/HEAD new file mode 100644 index 0000000000000000000000000000000000000000..cc8b805109083df88d06e7acbb36f4233f663645 --- /dev/null +++ b/vendors/irmin/.git_back/logs/refs/remotes/origin/HEAD @@ -0,0 +1 @@ +0000000000000000000000000000000000000000 df93d50134aad5e6c8fe766a47c044e89cd051df vicall 1657266479 +0200 clone: from https://github.com/mirage/irmin diff --git a/vendors/irmin/.git_back/objects/pack/pack-040d8da17565e9d5e5bd9709bd3da5c5db2faae9.idx b/vendors/irmin/.git_back/objects/pack/pack-040d8da17565e9d5e5bd9709bd3da5c5db2faae9.idx new file mode 100644 index 0000000000000000000000000000000000000000..29f5f3548b091467edb3ad5df0d1f40f04410c6a Binary files /dev/null and b/vendors/irmin/.git_back/objects/pack/pack-040d8da17565e9d5e5bd9709bd3da5c5db2faae9.idx differ diff --git a/vendors/irmin/.git_back/objects/pack/pack-040d8da17565e9d5e5bd9709bd3da5c5db2faae9.pack b/vendors/irmin/.git_back/objects/pack/pack-040d8da17565e9d5e5bd9709bd3da5c5db2faae9.pack new file mode 100644 index 0000000000000000000000000000000000000000..ad73d6df66c80456000e8352977361fd19db7a52 Binary files /dev/null and b/vendors/irmin/.git_back/objects/pack/pack-040d8da17565e9d5e5bd9709bd3da5c5db2faae9.pack differ diff --git a/vendors/irmin/.git_back/packed-refs b/vendors/irmin/.git_back/packed-refs new file mode 100644 index 0000000000000000000000000000000000000000..e8836f5853431d32d5e88180d4dac875aa61be83 --- /dev/null +++ b/vendors/irmin/.git_back/packed-refs @@ -0,0 +1,141 @@ +# pack-refs with: peeled fully-peeled sorted +67b8b0de96df4092e364fd26fe64da5a6ca90b98 refs/remotes/origin/1.4 +869fa50a7bd32445bfc84c7af3ef9952662af33f refs/remotes/origin/2 +0afd5de5e8cdd039d2898b136fbb04d3e76e4d1c refs/remotes/origin/2.10 +60903215d95e7491a502f49766e86a3220696019 refs/remotes/origin/2.2 +1eb87d8332cb656e12ba9a5ee4a8a65da5a5e6ef refs/remotes/origin/2.5 +5cede6a8cc7f005a919c17c636b2ce6e4fc3e741 refs/remotes/origin/2.6 +bb7f96ac8c7160957801fe228f02d1323b4ab75d refs/remotes/origin/2.7 +32271163abfea8f81fbcdb4d9e99a6595d2633cd refs/remotes/origin/2.8 +3631cd69e6241362701eaa5e0f71d1bf974f5d62 refs/remotes/origin/2.9 +d1321b7adc24f1858d5df936e0cdfe2fb078d941 refs/remotes/origin/2022_layered +ff6e6c249c8f201877ba217fe74c462f348d4983 refs/remotes/origin/3.2 +b9642d318b7c5558e9da31c3447478d8fc4a77da refs/remotes/origin/3.2.0 +df93d50134aad5e6c8fe766a47c044e89cd051df refs/remotes/origin/3.4 +3b6d981ed9c0d395602887f296137cf2a7e6aff9 refs/remotes/origin/blocking-dummy-gc +adb1b6f3255fd8c12e951458a79f0fd78e00c8b0 refs/remotes/origin/blocks +663d4e7dfa2d87db1d351166eb76e7db07e564ed refs/remotes/origin/gc +d723a66520c99f88d4511c6e36870966ae35cb97 refs/remotes/origin/gh-pages +d60a1fdef0494c470189100277ddf2c9aa985348 refs/remotes/origin/good-gc +df93d50134aad5e6c8fe766a47c044e89cd051df refs/remotes/origin/main +3882f15d247cdcadcbcdafc620757a1473d4b87d refs/remotes/origin/tjr@2022-01-17_additional_documentation +9b8dcbacd5d23ba99e226228c693fe1270f4b941 refs/tags/0.1 +^854ce9e0ac2071a99496c53c66558f481b835638 +d89ea0ae86f9e8e1ae0d983d7d45e74a8710d6d9 refs/tags/0.10.0 +^fd057673b7abcece3387a0bbfc804d64f91b55d7 +7538c09e8ce6748fb1cdb1dfe4473291711ef699 refs/tags/0.10.1 +^7794ca96fce56767f270d19cffe2fc0ba179ad48 +362d98528ae829299c510810440bc833bb67ea85 refs/tags/0.11.0 +^981eeb093ae11e201dbc21d630a7f455f866d2e8 +e91256d96a3f823e62cfd59f988ac85efc92ce45 refs/tags/0.11.1 +^afc128ad4b535c2bfa7064073744961327af5f08 +d2f0b107090f7927af8ffaa7bbf76012b7dc3e09 refs/tags/0.12.0 +^335f833dcd6bec230896c00a1513dcd957aca89e +acd6df188336e411b49c1abbb69fa9eb8e571cfa refs/tags/0.2 +^975bd511b1725b454e876efc1e6c031d6a501443 +323ebc4993977c4c056ea2229e4933b73cef4155 refs/tags/0.3.0 +c5d37765b9a5df210dc1020171251236f0994da2 refs/tags/0.4.0 +84cbdc476ab484c137d4c71e9c92a381737bfe25 refs/tags/0.5.0 +1254284824dff474c9470aaa20f9cefdd270b7bf refs/tags/0.5.1 +4ea4ee2bd9029fb6a7764ae13cf9947dedf49bf5 refs/tags/0.6.0 +68936f5ef87a99bf65fc980ae09b99f6314debed refs/tags/0.7.0 +aa0b51f4e32608620e4f180c9e4b7f6b284b59d6 refs/tags/0.8.0 +8b64f5f702e29b224d932ed255f0c6503717033d refs/tags/0.8.1 +1bcbb88edb3531458ca8123e5c2eb57a3ea494d9 refs/tags/0.8.2 +1b31fe31cf4f164febb5c7a602e1bd708b86c01d refs/tags/0.8.3 +1a9c37cf4a67724ce1251a5441abc0d917c99d6b refs/tags/0.9.0 +^43179a346ddc4e4af4af845dcfaab65aa1c284ee +a7e21912fcbc7b39a818837dfa9bc19a28478ce9 refs/tags/0.9.1 +947bf46e8cb0135811416746246e28a1304066a9 refs/tags/0.9.10 +^b1d5189f74d5f74b982122c2a273e8893ac0e5cc +c9b9e5baac2f73d981321bc722dca899ac4f15eb refs/tags/0.9.2 +^140f74430874c61700e7e7c5c512e6a260bce503 +3a057cf8b790057e7d16f0f5ac08a3c8ca6068ba refs/tags/0.9.3 +^88e0712cbe9615fddba8ebe55944bbe99edb8510 +8043496d002ac8406d75d19e8643bfbccfb0ab64 refs/tags/0.9.4 +^6d09b9f546ee5ce435d92b88680b091000f65f83 +e2bb6a3ea7622e023b283cf0b5221f3f38c0b46b refs/tags/0.9.5 +^b7b110d80d2599bc1ef30ba54c3a7cfad139c820 +e1fc060a83cdf95b9ff8f95f1c5ca5c07dbcaf8f refs/tags/0.9.6 +^368806d34f92b4f6548ccc7100341741105008de +5ff186bb0ed564aebafde42046da0a4d39daacd9 refs/tags/0.9.7 +^643a48c5187bf78d019cbabe559ab53c98bc8300 +172bce6c4d728e0c53b74929033f32f3b4b9a349 refs/tags/0.9.8 +^24150850f22e27be2975714bf7f6c2915da24990 +143101ee155c6de9542af7775cf7da070e17550d refs/tags/0.9.9 +^026b6de4d29e485c5c8055978f7ccb1f80d21a8e +65c7f8054ea74abe64ecbcba587773cbadbf94f2 refs/tags/1.0.0 +^e37074182a1ce1b4442e6aca489b54d78e644dab +5d7b142efd68116470d0ba6939768f33a0d01563 refs/tags/1.0.1 +^1139872f2a02db419c99b4a042613c8227d33885 +ec55403690265b5562e6415fd487b17eb783eaf7 refs/tags/1.0.2 +^f1430aefa2884b700071876fbdd41af3ce8d4b19 +cd126124d7d8f6927088edceeb95c0ab1ebf31a9 refs/tags/1.1.0 +^89196ad17c53b02f333022a87ecc264ec8c06af0 +647b9be7c81215a1daf4c2878c8d9c7654818025 refs/tags/1.2.0 +^3801feb49d31f5bef9150aa65aea32e3bee29216 +029dbc28e5fba2ed011ea593d3e7127f1c4b8012 refs/tags/1.3.0 +^910abc604637fa0260436a6a95e1aaa7e79dadac +80502145d7ebd4854ac5310910a844b37ac5bde1 refs/tags/1.3.1 +^320f2b3491977b6377976770e08465c3935a3b84 +731e819d8e4c7f7490f9c4ebae4087c9df179011 refs/tags/1.3.2 +^44049ead79d6484f2cadf677d98fe5c5f73f3956 +f30a8235a7267e11358606006c5f13925f514a05 refs/tags/1.3.3 +^855d361e3cb70c8438a8d77edb6fec5a2cf090fb +c0cf70d7ae6e5d9788b6393aa8c7f0750dd077cf refs/tags/1.4.0 +^615364620f4233cb82a96144824eb6ad5d1104f0 +00e1522a3b4dcfbf4352d65313101c308dd89440 refs/tags/2.0.0 +^47883bc5c46100ced0ffc17c313d3c93f92f055e +f7fd5b9a09e206af8204f887ca229ca0d8ca501f refs/tags/2.1.0 +^f6c8e16904a60410ec870b6d1bcda3d3e666a833 +b94232fedd019b2f82a5bacbf58019d044474da1 refs/tags/2.10.0 +^76541d91dda3a868784d6c8a4be8188c10129bf5 +e256d61224d7e1528ec89e5c973898bead7238ec refs/tags/2.10.1 +^19847d99551fa99df131388d42fb558957d9a33e +abd2295f351496368e12c01ee1ffef3d6610d504 refs/tags/2.10.2 +^9a2731c84eb8a9cef3a53b041d068b493979d14b +cb34125f62c2095383590b76e0b7311546b8ead1 refs/tags/2.2.0 +^a00ab54cd051632290223f2c8d1e83e3248ee1e1 +8d5eaac20e51564c1dbfbc9a9a1bda576ab6bc49 refs/tags/2.3.0 +^3e22238e86b6bac0c4eddff5b899efeaebe49dc9 +f9bba7d98d7e5afcf81a2c2449eba7d3d45b6f2a refs/tags/2.4.0 +^a517b827b26ef4beffae1c2e145d1b5492ba403e +e60acecb23f2bbe39ac3afda0643bb50e6cf322c refs/tags/2.5.0 +^ec64b0d8c1ea50046e8b081da999c5c34016cd87 +8f673cd50e75710aec97a19d05bda651cd517b7e refs/tags/2.5.1 +^9a0c3a316a6e4a9a69b8e2ddc518a597018b6f02 +42e3461d5fde0f954e36642af2fdb726be4cb115 refs/tags/2.5.2 +^b86d7c1632bdcb73f6b668d1d26cd9e3085758f8 +99c2d34609da1d7e23ca836f0a47a19fb6912e52 refs/tags/2.5.3 +^f04f87a63c47f82c996f4e2f4166af263f8efc21 +324b745efb6e42a99f964dd0ec87bcaee4d56915 refs/tags/2.5.4 +^1eb87d8332cb656e12ba9a5ee4a8a65da5a5e6ef +302981e6af637f6cd5fd9e1c5e2bc38bca57f4c7 refs/tags/2.6.0 +29169c5807c95bbc4a5811070f4a721482c4f917 refs/tags/2.6.1 +^2174147ae18fec599c9dc26871c91fa8d9ea8105 +ef6c80b53febb19b71e8f97336afac66ad576bb6 refs/tags/2.7.0 +^f660402387aceaab9f3b1823ac7425facb62d221 +fc69bebff03e5b03159bac9f8e9d11d81900bfed refs/tags/2.7.1 +^3c305fb302220d89d865d15b8b90897171ab5dd8 +830a09df335d412bc3277e33e47cc6f45cb15493 refs/tags/2.7.2 +^c8d715bdbab8cadaf1665fdd77e0e7e8bf4d16b1 +963135f275af96356d8bdfff7d3e33f6d3a5b130 refs/tags/2.8.0 +^e95b0fc693fbabad4be52a398e120d645c8e8f94 +4d8f2aba398eb063973840d8dd76467d7ea6ea55 refs/tags/2.9.0 +^faf08017dceb1b898dc6f6ac31269159bf8f9b75 +ac65e3b5fdf5f4b5d02922e1768535ba39b4238d refs/tags/2.9.1 +^8f485acbc3daebc5bc06e560210d35e3b0cb4187 +c4b0214005ce2a7094d7b03ecf641026369981ff refs/tags/3.0.0 +^2bedb02327cd3f05def9a67d7bbf74a0a574bf8f +0e029ab6b57d9a2d0dad4262b25a7fa76ae13665 refs/tags/3.1.0 +^dbe98b1f2681d506b53cd0f6cdf62dfe6ae19275 +74ab2c481858bab1855185f9ba3b7b81662ced07 refs/tags/3.2.0 +^b9642d318b7c5558e9da31c3447478d8fc4a77da +9700a1d16f789ea359237e06f9030580a9994d13 refs/tags/3.2.1 +^86e28b3888b01626012ab0728945cfbe60001877 +27688c9a03d7e01c353313f8121d32bae1ed0f4c refs/tags/3.2.2 +^8a03cc4b2939ba2f600ca6ff956ebc779d42a315 +8e66e2bb214c8af8a3c518c889368d71958ee495 refs/tags/3.3.0 +^3820bcae4da017ebd8ecb42e570369d8cd2d3504 +736105cbc4e5945f982098f4760b8814e918c12f refs/tags/3.3.1 +^a22b6213b6c0933b878bc14d0c497f7119b5f8eb diff --git a/vendors/irmin/.git_back/refs/heads/3.4 b/vendors/irmin/.git_back/refs/heads/3.4 new file mode 100644 index 0000000000000000000000000000000000000000..7492c3ff7c17801aefbf8895518f68f68a7eb582 --- /dev/null +++ b/vendors/irmin/.git_back/refs/heads/3.4 @@ -0,0 +1 @@ +df93d50134aad5e6c8fe766a47c044e89cd051df diff --git a/vendors/irmin/.git_back/refs/heads/main b/vendors/irmin/.git_back/refs/heads/main new file mode 100644 index 0000000000000000000000000000000000000000..7492c3ff7c17801aefbf8895518f68f68a7eb582 --- /dev/null +++ b/vendors/irmin/.git_back/refs/heads/main @@ -0,0 +1 @@ +df93d50134aad5e6c8fe766a47c044e89cd051df diff --git a/vendors/irmin/.git_back/refs/remotes/origin/HEAD b/vendors/irmin/.git_back/refs/remotes/origin/HEAD new file mode 100644 index 0000000000000000000000000000000000000000..4b0a87595873e6007ce078a8631d3a757097d1a0 --- /dev/null +++ b/vendors/irmin/.git_back/refs/remotes/origin/HEAD @@ -0,0 +1 @@ +ref: refs/remotes/origin/main diff --git a/vendors/irmin/.github/workflows/changelog-check.yml b/vendors/irmin/.github/workflows/changelog-check.yml new file mode 100644 index 0000000000000000000000000000000000000000..c731485f782a3baa31ffd5b9984643b739ce657c --- /dev/null +++ b/vendors/irmin/.github/workflows/changelog-check.yml @@ -0,0 +1,20 @@ +name: Changelog check + +on: + pull_request: + branches: [ main ] + types: [ opened, synchronize, reopened, labeled, unlabeled ] + +jobs: + build: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v1 + + - name: git diff + if: ${{ !contains(github.event.pull_request.labels.*.name, 'no-changelog-needed') }} + env: + BASE_REF: ${{ github.event.pull_request.base.ref }} + run: | + ! git diff --exit-code origin/$BASE_REF -- CHANGES.md diff --git a/vendors/irmin/.github/workflows/coverage.yml b/vendors/irmin/.github/workflows/coverage.yml new file mode 100644 index 0000000000000000000000000000000000000000..3f888004e97ffb01d00c527c716b7960e607ce4b --- /dev/null +++ b/vendors/irmin/.github/workflows/coverage.yml @@ -0,0 +1,67 @@ +name: coverage + +on: + push: + branches: + - main + pull_request: + schedule: + # Prime the caches every Monday + - cron: 0 1 * * MON + +jobs: + build: + if: github.repository_owner == 'mirage' + strategy: + fail-fast: false + matrix: + os: + - ubuntu-latest + packages: [ '.' ] + ocaml-compiler: + - 4.13.x + + runs-on: ${{ matrix.os }} + + steps: + - name: Set git to use LF + run: | + git config --global core.autocrlf false + git config --global core.eol lf + + - name: Checkout code + uses: actions/checkout@v2 + + - name: Use OCaml ${{ matrix.ocaml-compiler }} + uses: ocaml/setup-ocaml@v2 + with: + ocaml-compiler: ${{ matrix.ocaml-compiler }} + opam-local-packages: $${ matrix.opam-local-packages }} + opam-depext-flags: --with-test + + - name: Pin local packages + run: | + # Pin all local opam files to avoid internal conflicts + # + # TODO: replace with `opam pin --with-version` when Opam 2.1 is + # available via `setup-ocaml`. + find . -maxdepth 1 -name '*.opam' -printf '%P\n' |\ + cut -d. -f1 |\ + xargs -I{} -n 1 opam pin add {}.dev ./ -n + + - name: Install depexts + run: | + find . -maxdepth 1 -name '*.opam' -printf '%P\n' |\ + cut -d. -f1 |\ + xargs opam depext --update -y + + - name: Install Opam dependencies + run: opam install ${{ matrix.packages }} --with-test --deps-only + + - name: Run tests with coverage instrumentation + run: opam exec -- dune runtest --instrument-with bisect_ppx + + - name: Send coverage report to Codecov + run: opam exec -- bisect-ppx-report send-to Codecov + env: + PULL_REQUEST_NUMBER: ${{ github.event.number }} diff --git a/vendors/irmin/.gitignore b/vendors/irmin/.gitignore new file mode 100644 index 0000000000000000000000000000000000000000..33745a639c68a4f40279a198e585dad839b661b9 --- /dev/null +++ b/vendors/irmin/.gitignore @@ -0,0 +1,12 @@ +_build +_coverage +_metrics +*~ +*.install +*.merlin +_opam +.envrc +\#* +.#* +.*.swp +**/.DS_Store diff --git a/vendors/irmin/.ocamlformat b/vendors/irmin/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..b5fc1efd9a535457e296a1763648f9cd5a564a88 --- /dev/null +++ b/vendors/irmin/.ocamlformat @@ -0,0 +1,6 @@ +version = 0.21.0 +profile = conventional + +ocaml-version = 4.08.0 +break-infix = fit-or-vertical +parse-docstrings = true diff --git a/vendors/irmin/CHANGES.md b/vendors/irmin/CHANGES.md new file mode 100644 index 0000000000000000000000000000000000000000..9292d384974b998274c72a1aa23d332634f099cc --- /dev/null +++ b/vendors/irmin/CHANGES.md @@ -0,0 +1,1955 @@ +## Unreleased + +### Added + +- **irmin** + - Add `Tree.seq` to `Tree`'s public API (#1923, @metanivek) + +- **irmin-fs** + - Add unix subpackage, `irmin-fs.unix` (#1948, @metanivek) + +- **irmin-git** + - Add unix subpackage, `irmin-git.unix` (#1948, @metanivek) + +- **irmin-graphql** + - Add unix subpackage, `irmin-graphql.unix` (#1948, @metanivek) + +- **irmin-http** + - Add unix subpackage, `irmin-http.unix` (#1948, @metanivek) + +- **irmin-cli** + - Add new package for `irmin` command-line tool (#1951, @metanivek) + +- **irmin-pack** + - Add a GC (TODO) + +### Changed + +- **irmin** + - Replaced `Tree.node_fn` type with more general `Tree.folder` type to + represent the different ways to use `Tree.fold` (#1918, @metanivek) + +- **irmin-unix** + - Removed the `irmin-unix` package. Unix backends are now subpackages of their + relevant backend (see `irmin-fs.unix` and `irmin-git.unix`). The CLI tool is + in `irmin-cli`. For common unix utilities, see `irmin.unix`. (#1953, @metanivek) + +### Fixed + +## 3.3.1 (2022-06-22) + +### Fixed + +- **irmin-pack** + - Fix topology irregularities on disk which may lead to post-gc crashes. + (#1925, @Ngoguey42, @icristescu) + +## 3.3.0 (2022-06-20) + +### Added + +- **irmin** + - Add `Metrics` module to describe metric gathering in irmin. + (#1817, @maiste) + - Add `Repo.config` to access config used to create repo + (#1886, @zshipko) + +- **irmin-unix** + - Add `--plugin` flag to load Dynlink plugins that can register new + contents, hash and store types (#1808, @zshipko) + +- **irmin-pack** + - Add `use_fsync`, `dict_auto_flush_threshold` and + - `suffix_auto_flush_threshold` in store configuration. (#1865, @Ngoguey42) + - Add `no_migrate` in store configuration. (#1893, @zshipko) + +### Changed + +- **irmin-pack** + - Move `Irmin_pack.Pack_store.Indexing_strategy` to + `Irmin_pack.Indexing_strategy` and the rest of `Pack_store` + to `Irmin_pack_unix` (#1833, @Ngoguey42) + - Different repos opened using the same store module no longer share caches + and file descriptors (#1852, @Ngoguey42) + - `Snapshot.Import.close` requires a repo as additional argument (#1872, + @icristescu) + - Upgraded on-disk format to version 3 to support better synchronisation + mechanism between readwrite and readonly instances. This change is *not* + backwards-compatible with existing stores using `irmin-pack.x.x < 3.3.0` + versions. A migration done by the readwrite instance is necessary to open + older stores with `irmin-pack.3.3.0`. It is not forwards compatible. (#1865) + - Rename `Store.sync` to `Store.reload` (#1900, @Ngoguey42). + - Add `Pack_error` exception that centralizes many error cases alongside + `RO_not_allowed` and `Unix.Unix_error` (#1899, @Ngoguey42) + +### Fixed + +- **irmin-pack** + - Allow snapshot export to work on indexed root nodes (#1845, @icristescu) + +- **irmin** + - Fix Tree.export for nodes exported twice using different repos. (#1795, + @Ngoguey42) + +## 3.2.1 (2022-04-07) + +- Support all version of cmdliner (#1803, @samoht) + +## 3.2.0 (2022-03-28) + +### Added + +- **irmin-pack** + - Add `forbid_empty_dir_persistence` in store configuration. (#1789, + @ngoguey42) + - Add `Store.Snapshot` to expose the inodes for tezos snapshots (#1757, + @icristescu). + +### Changed + +- **irmin** + - Add error types in the API or proof verifiers. (#1791, @icristescu) + - Reduced the memory footprint of ``Tree.fold ~uniq:`True`` by a factor of 2. + (#1770, @CraigFe) + - Remove `clear` from all content addresssable stores. (#1794, @icristescu) + +## 3.1.0 (2022-02-25) + +### Fixed + +- **irmin-pack** + - Drop unnecessary runtime dependency on `ppx_irmin`. (#1782, @hhugo) + - Split the unix part of irmin-pack into irmin-pack.unix (#1783, @hhugo) + +- **irmin-unix** + - Fix conflicting command line arguments for `push`, `pull`, `fetch` and + `clone` (#1776, @zshipko) + - Fix issues with Sync functions by provided a better default `Mimic.ctx`. A + side-effect of this update is that the `remote` function now returns an Lwt + promise. (#1778, @zshipko) + +### Added + +- **libirmin** + - Create `libirmin` package providing a C interface to the irmin API + (#1713, @zshipko) + +### Changed + +- **irmin-bench** + - Make trace replay API public and simpler (#1781, @Ngoguey42) + +## 3.0.0 (2022-02-11) + +### Fixed + +- **irmin** + - Fix the implementation of comparison on `Irmin.Tree` objects to use the + comparison defined on hashes. The previous implementation was unstable. + (#1519, @CraigFe) + - Default implementation for contents, nodes and commits can no longer trigger + pre_hash collisions. This changes their hash. (#1715, @Ngoguey42, + @icristescu) + +- **irmin-pack** + - Improve the performance of Index encode and decode operations by + eliminating intermediate allocations. (#1577, @CraigFe) + +- **irmin-unix** + - Fix terms that can be manipulated at runtime by delaying computation + (#1645, @zshipko) + +### Added + +- **irmin** + - Add `Read_only.S` and `Read_only.Maker` module types (#1343, @samoht) + - Append-only and content-addressable backend implementations have to + provide `close` and `batch` functions (#1345, @samoht) + - Atomic-write backend implementations have to provide a `close` function + (#1345, @samoht) + - Add a function `Store.Tree.singleton` for building trees with a single + contents binding. (#1567, @CraigFe) + - Add `with_handler` and `head` to `Store.Backend.Node` and + `Store.Backend.Node_portable`to work with recursive node structures from + irmin core. (#1712, #1746 @Ngoguey42). Forward + port of #1692 and #1670. + - Add `proof`, `to_proof` and `of_proof` to `Store.Backend.Node_portable` + (#1716, @Ngoguey42). Forward port from #1583. + - Add `hash_exn` to `Store.Backend.Node.Val` and `Store.Backend.Node_portable` + (#TODO, @Ngoguey42) Forward ported from #1741. + - Add a `Store.Tree.kinded_hash` function. (#1767, @Ngoguey) Forward ported + from #1625. + - Add `Contents.String_v2`, `Node.Generic_key.Make_v2` and + `Commit.Generic_key.Make_v2` for backward compatibility with older stores. + (#1715, @icristescu) + +- **irmin-bench** + - Many improvements to the actions trace replay: + - Support for the layered store (#1293, @Ngoguey42) + - Fix replay for the first ~650k commits (was ~13k) (#1314, @Ngoguey42) + - Can change inode configuration prior to replay (#1326, @Ngoguey42) + - Check hash of commits (#1328, @icristescu) + - Fix the path flattening technique (#1357, @Ngoguey42) + - Introduce a new actions trace that can support replaying up to ~1300k + commits. (#1358, @Ngoguey42) + - Improve the stats collection and stats report (#1367, #1384, #1403, + #1404, #1416, #1429, #1438, #1501, #1616, @Ngoguey42, @maiste) + - Enable replay in CI (#1430, @Ngoguey42) + - Enable replay in CB (#1441, @Ngoguey42) + +- **irmin-mem** + - Add `Irmin_mem.Content_addressable` (#1369, @samoht) + +- **irmin-pack** + - Add a `stat-store` command to `irmin-fsck` to output stats on the tree + under a specified commit (#1391, @icristescu, @Ngoguey42, @CraigFe). + - Add new counters in `Stats` (#1570, @Ngoguey42). + - Add an option to configure the index function and pick the relevant bits + in a cryptographic hash by default (#1677 #1699, @samoht) + - Verify inode depth invariants (#1711, @Ngoguey42). Forward port of #1665. + +- **irmin-unix** + - Update `irmin` CLI to raise an exception when an invalid/non-existent + config file is specified (#1413, @zshipko) + - Add `--commit` flag to CLI to load a store from a specific commit hash + (#1721, @zshipko) + +- **irmin-tezos** + - Add a new package to mirror Tezos `tezos-context.encoding` library. + That'll simplify building benchmarks and custom tools (#1579, @samoht) + +### Changed + +- **irmin** + - `Irmin.Sync` is now a namespace: use `Irmin.Sync.Make(S)` instead of + `Irmin.Sync(S)` (#1338, @samoht) + - `Irmin.Private` is now `Irmin.Backend` (#1530, @CraigFe) + - `Store.master` is now `Store.main`. The existing `Store.master` function is + deprecated and will be removed in a future release. (#1564, @CraigFe) + - `Store.Private` is now `Store.Backend` (#1530, @CraigFe) + - `Store.Private.Sync` is now `Store.Backend.Remote` (#1338, @samoht) + - `Irmin.Branch.S.master` is now `Irmin.Branch.S.main` (#1564, @CraigFe) + - `Irmin.Private.{Commit,Node}` are now `Irmin.{Node,Commit}`. (#1471, + @CraigFe) + - All module types are now using snake-case and are not capitalized anymore. + (#1341, @samoht) + - Move signatures for backend stores into their own modules. All the + `X_STORE` sigs have moved to `X.S`: + - `APPEND_ONLY_STORE` is now `Append_only.S` + - `CONTENT_ADDRESSABLE_STORE` is now `Content_addressable.S` + - `ATOMIC_WRITE_STORE` is now `Irmin.Atomic_write.S` + And all the `X_STORE_MAKER` have moved to `X.Maker`: + - `APPEND_ONLY_STORE_MAKER` is now `Append_only.Maker` + - `CONTENT_ADDRESSABLE_STORE_MAKER` is now `Content_addressable.Maker` + - `ATOMIC_WRITE_STORE_MAKER` is now `Atomic_write.Maker` + This gives some space to move convenient functors closer to where they + belong: + - `Content_addressable` is now `Content_addressable.Make` + - New `Content_adddressable.Check_closed` and `Atomic_write.Check_closed` + (#1342, @samoht) + - Rename `Irmin.Make` into `Irmin.Maker` ; stage its result to return + `Make` functor once provided with a content-addressable and an + atomic-writes stores (#1369, @samoht) + - Rename `Irmin.Make_ext` into `Irmin.Maker_ext` ; stage its result to + return `Make` functor once provided with a content-addressable and an + atomic-writes stores, as well as node and commit makers (#1369, @samoht) + - Require at least `lwt.5.3.0` to use `Lwt.Syntax` in the codebase + (#1401, @samoht) + - `Info` implementations are not part of store: use `S.Info.v` + instead of `Irmin.Info.v` (#1400, @samoht) + - Rename `Commit.V1` to `Commit.V1.Make`. This functor now takes separate + hash and key implementations as arguments. (#1431 #1634, @CraigFe + @icristescu) + - Introduce a `Schema` module to hold all the types that users can + define in an Irmin store. Use this as a parameter to every `Maker` + functor. This is a large change which touches all the backends. + (#1470, @samoht, @CraigFe) + - Add `Irmin.Backend.Conf.Schema` for grouping configuration keys. Now + `Irmin.Backend.Conf.key` takes an additional `~spec` parameter. + (#1492, @zshipko) + - `Tree.empty` and `Node.empty` now both take a unit argument. (#1566 #1629, + @CraigFe) + - Rename `key` type to `path` and `Key` module to `Path` when it is in a path + context in `Tree` and `Store`. (#1569, @maiste) + - Move `Node.default` metadata default values into a `Node.Metadata.default` + to give room for other metadata values (#1611, @samoht) + + - Add support for non-content-addressed ("generic key") backend stores. This + allows Irmin to work with backends in which not all values are addressed by + their hash. In particular, this includes: + - New functions: `Store.{Commit,Contents,Tree}.of_key`. + - Adds `Irmin.{Node,Commit}.Generic_key` modules. + - Adds new types that must be provided by backends: `Node.Portable` and + `Commit.Portable`. + - Adds a new type of backend store: `Irmin.Indexable.S`. + (#1510 #1647, @CraigFe) + - Cache hits in several `Tree` functions are more frequent than before. + (#1724, @Ngoguey42, @CraigFe) + - Add a new `Pruned_hash` tag to the error case of several `Store.Tree` + functions (#1744 @Ngoguey42). Forward ported from #1583. + +- **irmin-containers** + - Removed `Irmin_containers.Store_maker`; this is now equivalent to + `Irmin.Content_addressable.S` (#1369, @samoht) + - Renamed `Irmin_containers.CAS_maker` to + `Irmin_containers.Content_addressable` (#1369, @samoht) + +- **irmin-fs** + - Renamed `Irmin_fs.Make` into `Irmin_fs.Maker` (#1369, @samoht) + - Renamed `Irmin_fs.Make_ext` into `Irmin_fs.Maker_ext` (#1369, @samoht) + +- **irmin-git** + - All of the configuration keys have moved into their own namespace: + - `Irmin_git.root` is now `Irmin_git.Conf.root` + - `Irmin_git.head` is now `Irmin_git.Conf.head` + - `Irmin_git.bare` is now `Irmin_git.Conf.bare` + - `Irmin_git.level` is now `Irmin_git.Conf.level` + - `Irmin_git.buffers` is now `Irmin_git.Conf.buffers` + - `Irmin_git.dot_git` is now `Irmin_git.Conf.dot_git` + (#1347, @samoht) + - Renamed `Irmin_git.Make` into `Irmin_git.Maker` (#1369, @samoht) + - Require at least `git.3.7.0` in the codebase (#1632, @dinosaure) + +- **irmin-graphql**: + - Changed the name of the default branch node from `master` to `main` in the + GraphQL API. (#1564, @CraigFe) + - Updated to be compatible with generic keys. + - The `Key` type is now called `Path` to match the new name in `irmin` + - All `key` fields and parameters have been renamed to `path` + (#1618, @zshipko) + +- **irmin-mirage** + - Renamed `Irmin_mirage_git.Make` into `Irmin_mirage_git.Maker` + (#1369, @samoht) + +- **irmin-pack** + - Changed the implementation of backend store keys to use direct pointers to + store contents (by offset in the pack file) when possible, rather than + querying the index on each lookup. (#1659, @CraigFe @ngoguey42 @icristescu) + - The `Irmin_pack.Maker` module type now no longer takes a `Conf` argument. + (#1641, @CraigFe) + - The backend configuration type `Conf.S` requires a new parameter + `contents_length_header` that (optionally) further specifies the encoding + format used for commits in order to improve performance. (#1644, @CraigFe) + - Upgraded on-disk format of pack files to support more efficient lookups and + reduce indexing overhead. This change is fully backwards-compatible with + existing stores using `irmin-pack.2.x` versions, but not + forwards compatible. (#1649 #1655, @CraigFe @Ngoguey42) + - Added support for user-specified indexing strategies. The default strategy + is to index all objects appended to the pack file (as before), but users may + now choose to index fewer objects in order to improve the write performance + of the store, at the cost of introducing potential duplicate values to the + pack file. (#1664, #1761, @CraigFe, @maiste) + +- **irmin-unix** + - Clean up command line interface. Allow config file to be specified when + using `Irmin_unix.Resolver.load_config` and make command line options + take precedence over config options. + (#1464, #1543, #1607 @zshipko) + - `Irmin_unix.Resolver.destruct` has been removed (and partially replaced by + `Resolver.spec`). (#1603, @CraigFe) + - Update `irmin` CLI to support empty path in `list` subcommand. + (#1575, @maiste) + - Add new commands to CLI: `branches` for listing available branches and + `log` which is similar to `git log` (#1609, #1727, @zshipko) + - Update `irmin watch` to take parameters to specify a command that should + be executed when there are new changes (#1608, @zshipko) + +### Removed + +- **irmin-pack** + - Removed the `irmin-pack.layered` library. Support for the layered store + will be restored on a future release of `irmin-pack`. (#1651, @CraigFe) + - Removed support for the `clear` operation in `irmin-pack`. This operation + is incompatible with performance optimisations made in this release. + (#1655, @CraigFe) + +- **irmin-layers** + - This experimental package has been removed. + +## 2.10.2 (2022-02-02) + +### Fixed + +- **irmin** + - Fixed a bug causing stream proof extender nodes to have their segments be + returned in reverse order (i.e. bottom to top, rather then top-down). + (#1742, @CraigFe) + + - Fixed a bug that allowed the creation of overly-large stable inodes via + stream proofs. (#1741, @Ngoguey42) + +### Added + +- **irmin** + - Add `Store.Private.Node.Val.hash_exn` (#1741, @Ngoguey42) + +## 2.10.1 (2022-01-20) + +### Fixed + +- **irmin** + - Fix bug introduced in #1683 which causes `Tree.seq` and `Tree.list` to + produce pruned children (#1720, @Ngoguey42) + +## 2.10.0 (2022-01-07) + +### Fixed + +- **irmin** + - Conversion between proofs and trees are now done in CPS (#1624, @samoht) + - Better support for s390x to workaround https://github.com/ocaml/ocaml/issues/10857 + (#1694, @icristescu) + +- **irmin-pack** + - Fix proofs for large inodes by tracking side-effects reads inside the + inode implementation (#1670, @samoht, @Ngoguey42) + - Flush branch store without calling `Repo.close` (#1707, @zshipko) + +### Added + +- **irmin** + - Add `Tree.produce_proof` and `Tree.verify_proof` to produce and verify + proofs from complex computations. `produce_proof` and `verify_proof` + takes a callback over tree and instead of a static list of operations + -- this now means that the full `Tree` API can now be used in proofs, + including sub-tree operations, folds and paginated lists + (#1625, #1663, #1683, @samoht, @Ngoguey42) + - Add `Tree.produce_stream` and `Tree.verify_stream` to produce and + verify stream proofs (#1684, #1692, #1691, @samoht, @Ngoguey42, @icristescu) + +- **irmin-pack** + - Verify inode depth invariants (#1665, @samoht) + +- **irmin-unix** + - Add `tezos` store type for `irmin` command-line (#1678, @zshipko) + +### Changed + +- **irmin** + - Remove `Tree.Proof.of_keys`. Use `Tree.produce_proof` instead + (#1625, @samoht) + - `Tree.empty` now takes a unit argument. (#1566, @CraigFe) + - `Tree.length` now takes a tree as argument (#1676, @samoht) + - `Tree.Proof.t` now uses a more precise datatype to encode value + invariants (#1688, @samoht) + +- **irmin-pack** + - irmin-pack: add an option to configure the index function and pick + the relevant bits in cryptographic a hash by default (#1677, @samoht) + +- **irmin-git** + - Require at least `git.3.7.0` in the codebase (#1637, @dinosaure) + +## 2.9.1 (2022-01-10) + +### Fixed + +- **irmin** + - Better support for s390x to workaround + https://github.com/ocaml/ocaml/issues/10857 (#1694, @icristescu) + +## 2.9.0 (2021-11-15) + +### Fixed + +- **irmin-pack** + - Improved the performance of Index encode and decode operations by + eliminating intermediate allocations (up to 5% fewer minor words + allocated) (#1577, @CraigFe) + - Reduce the number of backend nodes built during export + (up to 20% fewer minor words allocated) (#1553, @Ngoguey42) + +### Added + +- **irmin** + - Add Merkle Proofs and expose function to convert a proof to and from a tree. + Once converted, normal tree operations can be performed on the proof, as + long at it access values contained in the proof. + (#1583, @samoht, @Ngoguey42, @icristescu) + +### Changed + +- **irmin-pack** + - Limit inode depth (#1596, #samoht) + - Adapt to index 1.5.0 (#1593, @icristescu) + +## 2.8.0 (2021-10-15) + +### Fixed + +- **irmin** + - `Tree` operations now raise a `Dangling_hash` exception when called with a + path that contains dangling hashes in the underlying store, rather than + interpreting such paths as ending with empty nodes (#1477, @CraigFe) + - Fix the pre-hashing function for big-endian architectures. (#1505, + @Ngoguey42, @dinosaure) + - Fix a bug in `Tree.export` where nodes could be exported before + some of their contents, resulting in indirect hashes in irmin-pack + (#1508, @Ngoguey42) + +### Added + +- **irmin** + - `Node.seq` and `Node.of_seq` are added to avoid allocating intermediate + lists when it is not necessary (#1508, @samoht) + - New optional `cache` parameter to `Tree.hash`, `Tree.Contents.hash`, + `Tree.list`, `Node.list`, `Node.seq` and `Node.find` to control the storing + of lazily loaded data (#1526, @Ngoguey42) + - Add `Node.clear` to clear internal caches (#1526, @Ngoguey42) + - Added a `tree` argument to `Tree.fold` to manipulate the subtrees (#1527, + @icristescu, @Ngoguey42) + - Add a function `Store.Tree.pruned` for building purely in-memory tree + objects with known hashes. (#1537, @CraigFe) + - Added a `order` argument to specify the order of traversal in `Tree.fold` + (#1548, @icristescu, @CraigFe) + +### Changed + +- **irmin** + - `Node.v` is renamed to `Node.of_list` (#1508, @samoht) + - Rewrite `Tree.export` in order to minimise the memory footprint. + (#1508, @Ngoguey42) + - Remove the ``~force:`And_clear`` case parameter from `Tree.fold`, + ``~force:`True ~cache:false`` is the new equivalent. (#1526, @Ngoguey42) + - `` `Tree.fold ~force:`True`` and `` `Tree.fold ~force:`False`` don't + cache the lazily loaded data any more. Pass `~cache:true` to enable it + again. (#1526, @Ngoguey42) + - Do not allocate large lists in `Irmin.Tree.clear` (#1515, @samoht) + +- **irmin-git** + - Upgrade `irmin-git` to `git.3.5.0`. (#1495, @dinosaure) + +## 2.7.2 (2021-07-20) + +### Added + +- **irmin-pack** + - Added `integrity-check-index` command in `irmin-fsck`. (#1480, #1487 + @icristescu, @samoht) + +### Changed + +- **irmin-pack** + - `reconstruct_index` is now `traverse_pack_file`, it allows for both index + reconstruction and index checking (#1478, @Ngoguey42) + +## 2.7.1 (2021-07-02) + +### Fixed + +- **irmin-pack** + - Fix termination condition of reconstruct index (#1468, @Ngoguey42) + +## 2.7.0 (2021-06-22) + +### Fixed + +- **irmin** + - Added `Store.Tree.length`. (#1316, @Ngoguey42) + - Fixed fold for non-persisted, cleared trees (#1442, @samoht, @Ngoguey42) + +- **irmin-layers** + - Do not fail on double-close errors for private nodes (#1421, @samoht) + +- **irmin-pack** + - Do not clear and bump the generation for empty files (#1420, @samoht) + +### Added + +- **irmin-pack** + - Added `Irmin_pack.Version.{V1,V2}` modules for convenience. (#1457, + @CraigFe) + - Added a `irmin-pack.mem` package (#1436, @icristescu, @craigfe) + +- **irmin-graphql** + - Added `last_modified` field to GraphQL interface (#1393, @kluvin) + +### Changed + +- **irmin-layers** + - Remove `copy_in_upper` from the repo configuration. The default is now to + copy. (#1322, @Ngoguey42) + - Simplify the API of `freeze`. It is now possible to specify two distinct + commit closures for the copy to lower and the copy to next upper. + (#1322, @Ngoguey42) + - Renamed `Irmin_layered_pack.Make` and Irmin_layers.Make` into + `Irmin_layered_pack.Maker` and `Irmin_layers.Maker` (#1369, @samoht) + - Renamed `Irmin_layered_pack.Make_ext` and and Irmin_layers.Make_ext` into + into `Irmin_layered_pack.Maker_ext` and `Irmin_layers.Maker_ext` + (#1369, @samoht) + - Renamed `Irmin_layered_pack.Config` into `Irmin_layered_pack.Conf` + (#1370, @samoht) + - Readonly instances can check for an ongoing freeze (#1382, @icristescu, + @Ngoguey42) + +- **irmin-pack** + - It is no longer possible to modify an `inode` that doesn't point to the root + of a directory. (#1292, @Ngoguey42) + - When configuring a store, is it no longer possible to set `entries` to a + value larger than `stable_hash`. (#1292, @Ngoguey42) + - Added number of objects to the output of `stat-pack` command in + `irmin-fsck`. (#1311, @icristescu) + - Renamed the `Version` module type into `Version.S` and `io_version` into + `version`. The `Pack.File` and `Atomic_write` functors now take + `Version` as their first parameter (#1352, @samoht) + - Renamed `Irmin_pack.Make` into `Irmin_pack.V1` (#1369, @samoht) + - Renamed `Irmin_pack.Config` into `Irmin_pack.Conf` (#1370, @samoht) + - Renamed `Irmin_pack.Pack` into `Irmin_pack.Content_addressable` and + `Irmin_pack.Pack.File` into `Irmin_pack.Content_addressable.Maker` + (#1377, @samoht) + - Moved `Irmin_pack.Store.Atomic_write` into its own module (#1378, @samoht) + - `Checks.Reconstruct_index.run` now takes an optional `index_log_size` + parameter for customising the interval between merges during + reconstruction. (#1459, @CraigFe) + +## 2.6.1 (2021-04-29) + +This release contains 2.6.0 plus the changes described in 2.5.4. + +## 2.6.0 (2021-04-13) + +** Note: this release is based on 2.5.3, and does not contain 2.5.4. Use 2.6.1 +for access to those changes. ** + +### Fixed + +- **irmin** + - Fix stack overflow exception when working with wide trees (#1313, @zshipko) + + - `Tree.of_concrete` now prunes empty subdirectories, and raises + `Invalid_argument` if the input contains duplicate bindings. (#1385, + @CraigFe) + +- **irmin-chunk** + - Use the pre_hash function to compute entry keys instead of + their raw binary representation (#1308, @samoht) + +### Changed + +- **irmin-git** + - Upgrade `irmin-git` with `git.3.4.0`. (#1392, @dinosaure) + +## 2.5.4 (2021-04-28) + +### Fixed + +- **irmin-pack** + - Revert a patch introduced in 2.3.0 which was calling `Index.try_merge`. + This function was supposed to hint index to schedule merges after + every commit. However, `Index.try_merge` is buggy and stacks merges + which causes the node to block and wait for any existing merge to + complete. We will revisit that feature in future once we fix + `Index.try_merge` (#1409, @CraigFe) + +- **irmin** + - Fix peformance issue in `Tree.update_tree` and `Tree.add_tree` for + large directories (#1315, @Ngoguey42) + +### Added + +- **irmin-pack** + - Expose internal inode trees (#1273, @mattiasdrp, @samoht) + +## 2.5.3 (2021-04-13) + +### Fixed + +- **irmin** + - Fixed a bug causing equality functions derived from `Store.tree_t` to return + false-negatives. (#1371, @CraigFe) + +### Added + +- **irmin** + - Added `Store.Tree.is_empty`. (#1373, @CraigFe) + +## 2.5.2 (2021-04-08) + +### Fixed + +- **irmin** + - The `Tree.update_tree` and `Tree.add_tree` functions now interpret adding + an empty subtree as a remove operation, rather than adding an empty + directory. (#1335, @craigfe) + +- **irmin-pack** + - Fixed a performance regression where all caches were always cleaned by + `Store.sync` when using the V1 format (#1360, @samoht) + +## 2.5.1 (2021-02-19) + +- **irmin-git** + - Use the last version of git 3.3.0. It fixes a bug about trailing LF on + message. For Irmin users, it should not change anything (#1301, @dinosaure, + @CraigFe) + +## 2.5.0 (2021-02-16) + +### Changed + +- **irmin** + - `Store.Tree.remove` is now much faster when operating on large directories. + The commits following removals are also much faster. (#1289, @Ngoguey42) + + - Changed `Store.Tree.{of_hash, shallow}` to take kinded hashes, allowing the + creation of unforced contents values. (#1285, @CraigFe) + + - Changed `Tree.destruct` to return _lazy_ contents values, which may be forced + with `Tree.Contents.force`. (#1285, @CraigFe) + +- **irmin-bench** + - New features in benchmarks for tree operations (#1269, @Ngoguey42) + +## 2.4.0 (2021-02-02) + +### Fixed +- **irmin-pack** + - Fix a bug in `inode` where the `remove` function could cause hashing + instabilities. No user-facing change since this function is not being used + yet. (#1247, @Ngoguey42, @icristescu) + +- **irmin** + - Ensure that `Tree.add_tree t k v` complexity does not depend on `v` size. + (#1267, @samoht @Ngoguey42 and @CraigFe) + +### Added + +- **irmin** + - Added a `Perms` module containing helper types for using phantom-typed + capabilities as used by the store backends. (#1262, @CraigFe) + + - Added an `Exported_for_stores` module containing miscellaneous helper types + for building backends. (#1262, @CraigFe) + + - Added new operations `Tree.update` and `Tree.update_tree` for efficient + read-and-set on trees. (#1274, @CraigFe) + +- **irmin-pack**: + - Added `integrity-check-inodes` command to `irmin-fsck` for checking the + integrity of inodes. (#1253, @icristescu, @Ngoguey42) + +- **irmin-bench** + - Added benchmarks for tree operations. (#1237, @icristescu, @Ngoguey42, + @Craigfe) + +#### Changed + +- The `irmin-mem` package is now included with the `irmin` package under the + library name `irmin.mem`. It keeps the same top-level module name of + `Irmin_mem`. (#1276, @CraigFe) + +#### Removed + +- `Irmin_mem` no longer provides the layered in-memory store `Make_layered`. + This can be constructed manually via `Irmin_layers.Make`. (#1276, @CraigFe) + +## 2.3.0 (2021-01-12) + +### Fixed + +- **irmin-git** + - Update `irmin` to the last version of `ocaml-git` (#1065) + It fixes an issue on serialization/deserialization of big tree object + (see #1001) + +- **irmin-pack*** + - Fix a major bug in the LRU which was never used (#1035, @samoht) + +- **irmin*** + - Improve performance of `last_modified` (#948, @pascutto) + + - Changed the pattern matching of the function `last_modified`. The case of a + created key is now considered a modification by the function. (#1167, + @clecat) + + - Make Tree.clear tail-recursive (#1171, @samoht) + + - Fix `Tree.fold ~force:(False f)` where results where partially skipped + (#1174, @Ngoguey42, @samoht and @CraigFe ) + + - Fix `Tree.kind`. Empty path on a tree used to return a None instead of a + `` `Node``. (#1218, @Ngoguey42) + +- **ppx_irmin** + - Fix a bug causing certain type derivations to be incorrect due to unsound + namespacing. (#1083, @CraigFe) + +- **irmin-unix** + - Update irmin config path to respect `XDG_CONFIG_HOME`. (#1168, @zshipko) + +### Added + +- **irmin-layers** (_new_): + - Created a new package, `irmin-layers` that includes common signatures for + layered stores. It contains a stub `Make_layers` functor (#882, @icristescu) + +- **irmin-bench** (_new_): + - Created a new package to contain benchmarks for Irmin and its various + backends. (#1142, @CraigFe) + - Added ability to get json output and a make target to run layers benchmark. + (#1146, @gs0510) + +- **irmin** + - Added `Tree.Contents` module exposing operations over lazy tree contents. + (#1022 #1241, @CraigFe @samoht) + + - Added `Type.Unboxed.{encode_bin,decode_bin,size_of}` to work with unboxed + values (#1030, @samoht) + + - Remove the `headers` option in `Type.{encode_bin,decode_bin,size_of}`. Use + `Type.Unboxed.` instead (#1030, @samoht) + + - `Type.v` now takes an extra mandatory `unit` argument (#1030, @samoht) + + - Added `Type.pp_dump`, which provides a way to pretty-print values with a + syntax almost identical to native OCaml syntax, so that they can easily be + copy-pasted into an OCaml REPL for inspection. (#1046, @liautaud) + + - Generic functions in `Irmin.Type` are now more efficient when a partial + closure is constructed to the type representation (#1030 #1093, @samoht + @CraigFe). To make this even more explicit, these functions are now staged + and `Type.{unstage,stage}` can manipulate these. The goal is to encourage + users to write this kind of (efficent) pattern: + ```ocaml + let encode_bin = Type.(unstage (encode_bin ty)) + let _ = ... encode_bin foo ... + ``` + - Added a `clear` function for stores (#1071, @icristescu, @CraigFe) + + - Requires digestif>=0.9 to use digestif's default variants + (#873, @pascutto, @samoht) + + - Added `iter_commits` and `iter_nodes` functions to traverse the commits and + nodes graphs (#1077, @icristescu) + + - Added `Repo.iter` to traverse object graphs (#1128, @samoht) + +- **irmin-pack**: + - Added `index_throttle` option to `Irmin_pack.config`, which exposes the + memory throttle feature of `Index` in `Irmin-Pack`. (#1049, @icristescu) + + - Added `Pack.clear` and `Dict.clear` (#1047, @icristescu, @CraigFe, @samoht) + + - Added a `migrate` function for upgrading stores with old formats (#1070, + @icristescu, @CraigFe) + + - Added a `flush` function for a repo (#1092, @icristescu) + + - Added `Layered.Make functor, to construct layered stores from irmin-pack. + (#882, @icristescu) + + - Added `Checks.Make which provides some offline checks for irmin-pack + stores. (#1117, @icristescu, @CraigFe) + + - Added `reconstruct_index` to reconstruct an index from a pack file. (#1097, + @icristescu) + + - Added `reconstruct-index` command to `irmin-fsck` for reconstructing an index from + the command line (#1189, @zshipko) + + - Added `integrity-check` command to `irmin-fsck` for checking the integrity of + an `irmin-pack` store (#1196, @zshipko) + +- **ppx_irmin**: + + - Added support for deriving type representations for types with type + parameters. Type `'a t` generates a representation of type + `'a Type.t -> 'a t Type.t` (#1085, @CraigFe) + + - Added a `--lib` command-line option which has the same behaviour as the + `lib` run-time argument (i.e. `--lib Foo` will cause `ppx_irmin` to derive + type representations using combinators in the `Foo` module). (#1086, + @CraigFe) + + - Added an extension point `[typ: ]` for deriving type + representations inline. (#1087, @CraigFe) + +### Changed + +- **irmin** + - Renamed the `Tree.tree` type to `Tree.t`. (#1022, @CraigFe) + + - Replaced `Tree.pp_stats` with the type representation `Tree.stats_t`. (#TODO, @CraigFe) + + - Changed the JSON encoding of special floats. `Float.nan`, `Float.infinity` + and `Float.neg_infinity` are now encoded as `"nan"`, `"inf"` and `"-inf"` + respectively. (#979, @liautaud) + + - The functions `Type.{v,like,map}` no longer take a `~cli` argument, and now + take separate `~pp` and `~of_string` arguments instead. (#1103, @CraigFe) + + - The `Irmin.Type` combinators are now supplied by the `repr` package. The + API of `Irmin.Type` is not changed. (#1106, @CraigFe) + + - `Irmin.Type` uses staging for `equal`, `short_hash` and `compare` to + speed-up generic operations (#1130, #1131, #1132, @samoht) + + - Make `Tree.fold` more expressive and ensure it uses a bounded memory + (#1169, @samoht) + + - Changed `list` and `Tree.list` to take optional `offset` and `length` + arguments to help with pagination. Also return direct pointers to the + subtrees to speed up subsequent accesses (#1241, @samoht, @zshipko, + @CraigFe, @Ngoguey42 and @icristescu) + +- **irmin-pack**: + - `sync` has to be called by the read-only instance to synchronise with the + files on disk. (#1008, @icristescu) + + - Renamed `sync` to `flush` for the operation that flushes to disk all buffers + of a read-write instance. (#1008, @icristescu) + + - Changed the format of headers for the files on disk to include a generation + number. Version 1 of irmin-pack was used for the previous format, version 2 + is used with the new format. (#1047, @icristescu, @CraigFe, @samoht) + + - Use `Repo.iter` to speed-up copies between layers (#1149, #1150 @samoht) + + - Add an option to bypass data integrity checks on reads (#1154, @samoht) + + - Add `heads` parameter to `check-self-contained` command in `Checks` (#1224, @zshipko) + +- **ppx_irmin**: + + - The `[@generic ...]` attribute has been renamed to `[@repr ...]`. (#1082, + @CraigFe) + +## 2.2.0 (2020-06-26) + +### Added + +- **irmin**: + - Added `Irmin.Type.empty` to represent an uninhabited type. (#961, @CraigFe) + - Added `Store.Tree.concrete_t`. (#1003, @CraigFe) + +- **irmin-containers** (_new_): + - Created a new package, `irmin-containers`, which provides a set of simple + mergeable datastructures implemented using Irmin. (#1014, @ani003) + +- **ppx_irmin** + - Added support for the `@nobuiltin` attribute, which can be used when + shadowing primitive types such as `unit`. See `README_PPX` for details. + (#993, @CraigFe) + + - Added support for a `lib` argument, which can be used to supply primitive + type representations from modules other than `Irmin.Type`. (#994, @CraigFe) + +### Changed + +- **irmin**: + - Require OCaml 4.07 (#961, @CraigFe) + - Add sanity checks when creating `Irmin.Type` records, variants and enums + (#956 and #966, @liautaud): + - `Irmin.Type.{sealr,sealv,enum}` will now raise `Invalid_argument` if two + components have the same name; + - `Irmin.Type.{field,case0,case1}` will now raise `Invalid_argument` if + the component name is not a valid UTF-8 string. + - Changed the JSON encoding of options and unit to avoid ambiguous cases + (#967, @liautaud): + - `()` is now encoded as `{}`; + - `None` is now encoded as `null`; + - `Some x` is now encoded as `{"some": x}`; + - Fields of records which have value `None` are still omitted; + - Fields of records which have value `Some x` are still unboxed into `x`. + + - Changed pretty-printing of Irmin types to more closely resemble OCaml types. + e.g. `pair int string` prints as `int * string`. (#997, @CraigFe) + + - The type `Irmin.S.tree` is now abstract. The previous form can be coerced + to/from the abstract representation with the new functions + `Irmin.S.Tree.{v,destruct}` respectively. (#990, @CraigFe) + +- **irmin-mem** + - Stores created with `KV` now expose their unit metadata type. (#995, + @CraigFe) + +### Fixed + +- **irmin-graphql** + - Fixed an issue with keys inside `get_{contents,tree}` fields having + incorrect ordering (#989, @CraigFe) + +## 2.1.0 (2020-02-01) + +### Added + +- **ppx_irmin** (_new_): + - Created a new package, `ppx_irmin`, which provides a PPX deriving plugin + for generating Irmin generics. + +- **irmin-unix**: + - Added a `--hash` parameter to the command-line interface, allowing the hash + function to be specified. For BLAKE2b and BLAKE2s, the bit-length may be + specified with a trailing slash, as in `--hash=blake2b/16`. The `hash` + function may also be specified in the configuration file. (#898, @craigfe) + +- **irmin**: + - Added `Irmin.Hash.Make_BLAKE2B` and `Irmin.Hash.Make_BLAKE2S` functors for + customizing the bit-length of these hash functions. (#898, @craigfe) + - Added `iter` function over a closure graph (#912, @ioana) + - Added `Type.pp_ty` for pretty-printing Irmin generics. (#926, @craigfe) + - Added `Merge.with_conflict` for modifying the conflict error message of a + merge function. (#926, @craigfe) + +### Changed + +- **irmin-pack**: + - Changed the bit-length of serialized hashes from 60 to 30. (#897, + @icristescu) + - `integrity_check` can now try to repair corrupted values. (#947, @pascutto) + +- **irmin-graphql**: + - Changed default GraphQL type names to ensure uniqueness. (#944, @andreas) + +## 2.0.0 + +### Added + +- **irmin-pack** (_new_): + - Created a new Irmin backend, `irmin-pack`, which uses a space-optimised + on-disk format. + +- **irmin-graphql** (_new_): + - Created a new package, `irmin-graphql`, which provides a GraphQL server + implementation that can be used with both the MirageOS and Unix backends. + Additionally, a `graphql` command has been added to the command-line + interface for starting `irmin-graphql` servers. (#558, @andreas, @zshipko) + + - Contents can now be queried directly using `irmin-graphql` with + `Irmin_graphql.Server.Make_ext` and the `Irmin_graphql.Server.PRESENTER` + interface. (#643, @andreas) + +- **irmin-test** (_new_): + - Added a new package, `irmin-test`, which allows for packages to access the + Irmin test-suite. This package can now be used for new packages that + implement custom backends to test their implementations against the same + tests that the core backends are tested against. (#508, @zshipko) + +- **irmin-unix**: + - Add `Cli` module to expose some methods to simplify building command-line + interfaces using Irmin. (#517, @zshipko) + + - Add global config file `$HOME/.irmin/config.yml` which may be overridden by + either `$PWD/.irmin.yml` or by passing `--config `. See `irmin help + irmin.yml` for details. (#513, @zshipko) + +- **irmin-git**: + - Allow import/export of Git repositories using Irmin slices. (#561, @samoht) + +- **irmin-http**: + - Expose a `/trees/merge` route for server-side merge operations. (#714, + @samoht) + +- **irmin**: + - Add `Json_value` and `Json` content types. (#516 #694, @zshipko) + + - Add optional seed parameter to the `Irmin.Type` generic hash functions. + (#712, @samoht) + + - Add `V1` submodules in `Commit`, `Contents` and `Hash` to provide + compatibility with 1.x serialisation formats. (#644 #666, @samoht) + + - Add `Store.last_modified` function, which provides a list of commits where + the given key was modified last. (#617, @pascutto) + + - Add a `Content_addressable.unsafe_add` function allowing the key of the new + value to be specified explicitly (for performance reasons). (#783, @samoht) + + - Add `save_contents` function for saving contents to the database. (#689, + @samoht) + + - Add pretty-printers for the results of Sync operations. (#789, @craigfe) + + - `Private.Lock` now exposes a `stats` function returning the number of held + locks. (#704, @samoht) + +### Changed + +- **irmin-unix**: + - Rename `irmin read` to `irmin get` and `irmin write` to `irmin set`. (#501, + @zshipko) + + - Switch from custom configuration format to YAML. (#504, @zshipko) + +- **irmin-git**: + - Require `ocaml-git >= 2.0`. (#545, @samoht) + + - Cleanup handling of remote stores. (#552, @samoht) + +- **irmin-http**: + - Rename `CLIENT` to `HTTP_CLIENT` and simplify the signatures necessary to + construct HTTP clients and servers. (#701, @samoht) + +- **irmin-mirage** + - Split `irmin-mirage` into `irmin-{mirage,mirage-git,mirage-graphql}` to + allow for more granular dependency selection. Any instances of + `Irmin_mirage.Git` should be replaced with `Irmin_mirage_git`. (#686, + @zshipko) + +- **irmin**: + - Update to use dune (#534, @samoht) and opam 2.0. (#583, @samoht) + + - Replace `Irmin.Contents.S0` with `Irmin.Type.S`. + + - Rename `Type.pre_digest` -> `Type.pre_hash` and `Type.hash` -> + `Type.short_hash`. (#720, @samoht) + + - Change `Irmin.Type` to use _incremental_ hash functions (functions of type + `'a -> (string -> unit) -> unit`) for performance reasons. (#751, @samoht) + + - Simplify the `Irmin.Type.like` constructor and add a new `Irmin.Type.map` + with the previous behaviour. + + - Improvements to `Irmin.Type` combinators. (#550 #538 #652 #653 #655 #656 + #688, @samoht) + + - Modify `Store.set` to return a result type and create a new `Store.set_exn` + with the previous exception-raising behaviour. (#572, @samoht) + + - Rename store module types to be more descriptive: + - replace `Irmin.AO` with `Irmin.CONTENT_ADDRESSABLE_STORE`; + - replace `Irmin.AO_MAKER` with `Irmin.CONTENT_ADDRESSABLE_STORE_MAKER`; + - replace `Irmin.RW` with `Irmin.ATOMIC_WRITE_STORE`; + - replace `Irmin.RW_MAKER` with `Irmin.ATOMIC_WRITE_STORE_MAKER`. (#601, + @samoht) + + - Rename `export_tree` to `save_tree` (#689, @samoht) and add an option to + conditionally clear the tree cache (#702 #725, @samoht). + + - Change hash function for `Irmin_{fs,mem,unix}.KV` to BLAKE2b rather than + SHA1 for security reasons. (#811, @craigfe) + + - Move `Irmin.remote_uri` to `Store.remote`, for stores that support remote + operations. (#552, @samoht) + + - Simplify the error cases of fetch/pull/push operations. (#684, @zshipko) + + - A `batch` function has been added to the backend definition to allow for + better control over how groups of operations are processed. (#609, @samoht) + + - A `close` function has been added to allow backends to close any held + resources (e.g. file descriptors for the `FS` backend). (#845, @samoht) + + - Simplify `Private.Node.Make` parameters to use a simpler notion of 'path' in + terms of a list of steps. (#645, @samoht) + + - Rename `Node.update` to `Node.add`. (#713, @samoht) + +### Fixed + +- **irmin-unix**: + - Fix parsing of commit hashes in `revert` command. (#496, @zshipko) + +- **irmin-git**: + - Fix `Node.add` to preserve sharing. (#802, @samoht) + +- **irmin-http**: + - Respond with a 404 if a non-existent resource is requested. (#706, @samoht) + +- **irmin**: + - Fix a bug whereby `S.History.is_empty` would return `true` for a store with + exactly one commit. (#865, @pascutto) + +### Removed + +- **irmin**: + - Remove `pp` and `of_string` functions from `Irmin.Contents.S` in favour of + `Irmin.Type.to_string` and `Irmin.Type.of_string`. + + - Remove `Bytes` content type. (#708, @samoht) + + - Remove `Cstruct` dependency and content type. If possible, switch to + `Irmin.Contents.String` or else use `Irmin.Type.map` to wrap the Cstruct + type. (#544, @samoht) + +## 1.4.0 (2018-06-06) + +- Add types for `Contents.hash`, `Tree.hash` and `Commit.hash` (#512, @samoht) +- `Tree.hash` and `Tree.of_hash` now work on leaf nodes. To do this, `Tree.hash` + has to return a more complex type (#512, @samoht) +- support for webmachine 0.6.0 (#505, @ansiwen) + +## 1.3.3 (2018-01-03) + +- complete support for OCaml 4.06 (#484, @samoht) +- support cohttp 1.0 (#484, @samoht) + +## 1.3.2 (2017-11-22) + +- support OCaml 4.06 where `-safe-string` is enabled by default (#477, @djs55) + +## 1.3.1 (2017-08-25) + +- irmin-http: update to cohttp.0.99 (#467, @samoht) + +## 1.3.0 (2017-07-27) + +**irmin-chunk** + +Add a new package: `irmin-chunk`, which was initially in a separate repository +created by @mounirnasrallah and @samoht and ported to the new Irmin API by +@g2p (#464) + +**irmin-unix** + +Re-add the `irmin` binary, the example application which used to be +installed by irmin-unix` before we switched to use `jbuilder` +(#466, @samoht -- reported by @ouenzzo and @dudelson) + +**irmin** + +That releases saw a nice series of patches to improve the performance of +`Irmin.Tree` contributed by the Tezos team: + +- Improve complexity of `Irmin.Tree` operations: on trivial benchmarks with + a lot of values, this patch introduces a 10-times speed-up + (#457, @OCamlPro-Henry) + +- Add missing equality for `Irmin.Type` primitives (#458, @OCamlPro-Henry) + +- Change the type of `Hash.digest` to also take a type representation + (#458, @OCamlPro-Henry) + +- add `Irmin.Type.{encode,decode}_cstruct` (#458, @OCamlPro-Henry) + +- remove `Irmin.Contents.RAW` (#458, @OCamlPro-Henry) + +- avoid unecessary serialization and deserialization when computing hashes + of cstructs (#459, @OCamlPro-Henry) + +- remove `{Type,Merge}.int` which might cause some issue on 32 bits platforms. + Intead use the more explicit (and portable) `{Type,Merge}.int32` or + `{Type,Merge}.int64` (#469, @samoht) + +## 1.2.0 (2017-06-06) + +This release changes the build system to use +[jbuilder](https://github.com/janestreet/jbuilder). By doing so, it introduces +two new packages: `irmin-mem` and `irmin-fs` -- containing `Irmin_mem` and +`Irmin_fs` respectively. That release also fixes a bunch of regressions +introduced in the big 1.0 rewrite. + +**all** + +- Use `jbuilder` (#444, @samoht) +- Use mtime 1.0 (#445, @samoht) + +**irmin** + +- Fix `Irmin.Contents.Cstruct`: pretty-print the raw contents, not the hexdump + (#442, @samoht) +- `Irmin.Hash.X.of_string` should not raise an exception on invalid hash + (#443, @samoht) + +**irmin-mem** + +- New package! Use it if you want to use the `Irmin_mem` module. + +**irmin-fs** + +- New package! Use it if you want to use the `Irmin_fs` module. + +**irmin-git** + +- Fix watches (#446, @samoht) + +## 1.1.0 (2017-04-24) + +**irmin** + +- Change the type of `S.Tree.find_tree` to return a `tree option` instead of + `tree`. This is a breaking API change but it let distinguish between + the empty and non-existent cases (#431, @samoht) +- Allow to specify branches in urls for fetch using the `url#branch` syntax + (#432, @samoht) +- Expose `Irmin.Merge.idempotent` for values with idempotent operations + (#433, @samoht) +- Add a `S.repo` type as an alias to the `S.Repo.t` (#436, @samoht) +- Fix regression in `S.Tree.diff` intoduced in the 1.0 release: nested + differences where reported with the wrong path (#438, @samoht) + +**irmin-unix** + +- Update to irmin.1.1.0 API changes (@samoht) + +**irmin-git** + +- Update to irmin.1.1.0 API changes (@samoht) + +## 1.0.2 (2017-03-27) + +**irmin** + +- Add a cstruct type combinator (#429, @samoht) +- Fix regression introduced in 1.0.1 on merge of base buffers (strings, + cstruct). For these types, updates are idempotent, e.g. it is fine + if two concurrent branches make the same update. (#429, @samoht) + +**irmin-unix** + +- Add irminconfig man page (#427, @dudelson) + +## 1.0.1 (2017-03-14) + +**irmin** + +- Default merge function should not assume idempotence of edits + (#420, @kayceesrk) +- Wrap the merge functions for pair and triple with the default case. + (#420, @kayceesrk) + +**irmin-unix** + +- Support all versions of cmdliner, 1.0.0 included (@samoht) + +## 1.0.0 (2017-02-21) + +Major API changes: + +- It is now simpler to define mergeable contents, using new + combinators to describe data-types (see `Type`). + +- The mutable views have been replaced by immutable trees, and made + first-class citizen in the API (see available `S.Tree`). + Transactions now only ensure snapshot isolation instead of full + serialisability. + +- Creating a store with default path and branch implementations + is now easier using the `KV` functors which just take one parameter: + the contents. + +- the backend and user-facing API are now totally independant (instead + of being half-included in each other in `irmin.0.*`), so that + backends have to implement the minimum set of functions to be + Irmin-compatible, and users can have many convenient high-level + functions when using the Irmin API. The backends implement + `AO` and `RW`, the frontend provides `S`. + +The package is also now split into 5 opam packages: `irmin`, irmin-git`, +`irmin-http`, `irmin-unix` and `irmin-mirage` with similarly named +`ocamlfind` libraries. + +More detailled changes: + +* use result type everywhere (#397, @samoht) +* use `Fmt` everywhere (#397, @samoht) +* rename `create` functions into `v` (#397, @samoht) + +**irmin** + +* [info] rename `Task` into `Info` to denote commit info (#397, @samoht) +* [info] remove `Task.uid` (#397, @samoht) +* [info] Commit messages are now plain strings (instead of a lists of + strings): change `Task.messages` into `Info.message`, take a string + instead of a list of strings as parameter and remove `Task.add` + (#397, @samoht) +* [info] change `Info.f` to only takes `unit` as argument. Previously + it was taken an `'a` which was used by the update functions. The + update functions now take a full `Info.f` function as parameter, + which should be less confusing (#397, @samoht) + +* [merge] replace the dependency to `mirage-tc` by a new internal module + `Type` using type-based combinators. This makes defining new mergeable + data-types much easier, especially records and variants (#397, @samoht) +* [merge] change [Merge.t] to be an abstract type (#397, @samoht) +* [merge] add [Merge.f] to transform a [Merge.t] value into a merge function + (#397, @samoht) +* [merge] add base merge combinators: `Merge.unit`, `Merge.bool`, + `Merge.char`, `Merge.int`, `Merge.int32`, `Merge.int64`, + `Merge.float` (#397, @samoht) +* [merge] simplify the type of `Merge.option`, `Merge.pair`, Merge.triple` and + `Merge.alist` (#397, @samoht) +* [merge] simplify and rename `Merge.MSet` into `Merge.MultiSet` (#397, @samoht) +* [merge] simplify and rename `Merge.set` into `Merge.Set` (#397, @samoht) +* [merge] rename `Merge.OP` into `Merge.Infix` and rename operators to + avoid name-clashing with other monads (#397, @samoht) +* [merge] remove the `path` argument from the merge functions (#397, @samoht) +* [merge] remove the need to defined a `Path` submodule in `Contents.S` + (#397, @samoht) +* [merge] add a (very simple at the moment) `Diff` module (#397, @samoht) + +* [api] read operations do not take a task parameter anymore (#397, @samoht) +* [api] write operations not take a full commit info instead of a confusing + `'a` parameter (#397, @samoht) +* [api] rename [Ref] into [Branch] (#397, @samoht) +* [api] replace `S.read` by `S.find` (#397, @samoht) +* [api] replace `S.read_exn` by `S.get` (#397, @samoht) +* [api] add `S.kind` to check the kind of store entries (files, directories) + (#397, @samoht) +* [api] remove the `View` functor, replaced by first-class support for + immutable trees `S.Tree` (#397, @samoht) +* [api] add `S.find_tree` to find immutable subtrees (#397, @samoht) +* [api] add `S.find_all` to find contents and metadat (#397, @samoht) +* [api] change `S.mem` to only check for contents, not subtree (#397, @samoht) +* [api] add `S.mem_tree` to check for subtrees (similar behavior to + `S.mem` in `irmin.0.*`) (#397, @samoht) +* [api] add `S.with_tree` for atomic update of subtrees. This + operation replaces `with_hrw_view`, but a weaker consistency + guarantee: instead of providing full seriasilabilty, `S.with_tree` + provides snapshot isolation, which is consistent enough for most of + the users. (#397, @samoht) +* [api] rename `S.update` into `S.set` and ensure that the operation is + atomic by using a combination of test-and-set and optimistic concurrency + control. (#397, @samoht) +* [api] change `S.remove` to ensure the operation is atomtic. +* [api] add `S.status` to mimick `git status`. (#397, @samoht) +* [api] remove all the `_id` suffixes. (#397, @samoht) +* [api] add `S.merge_with_commit` and `S.merge_with_branch` (#397, @samoht) +* [api] more precise return type for `S.Head.fast_forward` (#401, @samoht) +* [api] add `S.Commit`, `S.Branch` (#401, @samoht) +* [api] add `KV_MAKER` to ease the creation of store with string lists + as paths and strings as branches (#405, @samoht) + +* [backend] replace `RO.read` by `RO.find` (#397, @samoht) +* [backend] no more `RO.read_exn` (#397, @samoht) +* [backend] no more `RO.iter`, replaced by `RW.list` (#397, @samoht) +* [backend] replace `RW.update` by `RW.set` (#397, @samoht) +* [backend] rename `RW.compare_and_set` into `RW.test_and_set` (#397, @samoht) +* [backend] new `RW.watch`, `RW.watch_key` and `RW.unwatch` functions + to set-up low-level notifications (#397, @samoht) + +**irmin-git** + +- Adapt to `git.0.10.0` (#397, @samoht) +- Remove the `LOCK` modules (#397, @samoht) +- Rename `S.Internals` into `S.Git` (#397, @samoht) +- Rename `S.Internals.commit_of_id` into `S.Git.git_commit` (#397, @samoht) +- Add `S.Git.of_repo` to convert an Irmin repo into a Git repo (#397, @samoht) +- Add `S.Git.to_repo` to convert a Git repo into an Irmin repo (#397, @samoht) +- Expose `S.Git_mem.clear` and `S.Git_mem.clear_all` for in-memory Git + backends (#397, @samoht) +- Rename `Memory` into `Mem.Make` (#405, @samoht) +- Rename `FS` into `FS.Make` (#405, @samoht) +- Remove `CONTEXT` and fold it into `IO` (#405, @samoht) +- Add `Mem.KV` and `FS.KV` to ease creatin of store with default + implementations for branches and paths (#405, @samoht) +- Add `Mem.Ref` and `FS.Ref` access tags, remotes and other Git references + (#407, @samoht) +- Allow to set-up a custom `.git` path (#409, @samoht) + +**irmin-mirage** + +- Adapt to Mirage3 (@hannesm, @yomimono, @samoht) +- Rename the `Task` module into `Info` to reflect the core API changes +- Change `Info.f` to accept an optional `author` argument and a format + string as a message parameter (#261, #406 @samoht) +- Rename `Irmin_git` into `Git` (#405, @samoht) + +**irmin-http** + +- Remove the high-level HTTP API (#397, @samoht) +- Rewrite the low-level (backend) API using `ocaml-webmachine` (#397, @samoht) +- Add `KV` to ease creatin of store with default implementations for + branches and paths (#405, @samoht) + +**irmin-unix** + +- Rename `Irmin_unix.task` into `Irmin_unix.info` (#397, @samoht) +- Remove `LOCK` (#397, @samoht) +- Change `Irmin_unix.info` to take an optional `author` argument and accept + a format string as message parameter (#261, #406 @samoht) +- Rename `Irmin_fs` into `FS` (#405, @samoht) +- Rename `Irmin_git` into `Git` (#405, @samoht) +- Rename `Irmin_http` into `Http` (#405, @samoht) + +## 0.12.0 (2016-11-17) + +* Depends on irmin-watcher 0.2.0 to use portable file-system watches + (fsevents on OSX or inotify on Linux) to replace the slow and CPU + intensive file-system polling that was the default (#380, @samoht) +* Do not use `Lwt_unix.fork` in the tests anymore (#383, @samoht) +* Switch from Stringext to Astring (#382, @samoht) +* Fix regression in the tests for using Git over HTTP (#376, @samoht) +* Catch top-level exceptions in watch callbacks (#375, @samoht) +* Fix merge of assoc list with no common ancestor (#374, @samoht) +* Improve documentation for Git bare repositories (#363, @kayceesrk) +* New functor `Make_with_metadata` to customize the type of the + nodes metadata (#364, @samoht) +* Remove mentions of private modules from the public interface + (#364, @samoht) + +## 0.11.1 (2016-06-14) + +* Fix compilation of examples (#359, @samoht) + +## 0.11.0 (2016-05-04) + +* Use Logs (#342, @talex5) +* Improve non-unix portablity of `Irmin_fs` (#345, @samoht) +* Change the signature of `Store.iter` to defer opening the + file only when needed. This was causing a file-descriptor + early exhaustion on Windows (#345, @samoht) +* Fix paths for references on Windows (#345, @samoht) +* Port to `ocaml-git` 1.8.0 +* Rather large API change in `Irmin.Private.Contents.Store` + and `Irmin.Private.Commit.Store` to make it easier to + build new and efficient Irmin backends. (#346, @samoht) +* Fix performance problem in the computation of LCAs (#351, @talex5) +* Fix sort order for Git trees (#352, @talex5) + +## 0.10.1 (2015-11-26) + +* Support for launchd: the `--address` argument of the CLI now + supports a URI `launchd://` where `` corresponds + to the section in the property list file (#321, by @djs55) +* Expose `/watch-rec` in the REST API (#326, by @samoht) +* Expose Store.Key = Contents.Path in Irmin.Maker. Otherwise, + the type of steps is abstract. (#327, by @talex5) + +## 0.10.0 (2015-10-14) + +* Fix the `Irmin_mem` backend to work when equal keys might be not + structurally equal (`Pervasives.(=)` is evil) +* Fix `Hash.SHA1.equal` to always return true when the underlying + bigarrays are equals. Before that, this was only the case when + the whole `Cstruct.t` where identical: ie. same bigarray but also + same offset in the `Cstruct.t` value, which is obviously not + always the case. Apply the same fix to `Hash.SHA1.compare` and + `Hash.SHA1.hash`. +* Renamed "tag" to "branch" in the API, as "tag" is confusing for Git + users. `BC.tag` is now `BC.name` and `BC.branch` is now `BC.head_ref`. + The various "Tag" modules are now called "Ref" ("Branch" would be + confusing here since they only store references to commits, not the + branch contents). + Note: The remote HTTP protocol still uses "tag". +* Remove `Irmin_http_server.listen`. Instead, return the Cohttp + configuration for the server and let the user perform the listen. The + resulting API is simpler (removes `timeout` and `uri` parameters), + more flexible, and easier to use from Mirage. +* Remove `Irmin.task` from API of internal stores (commit, node, etc). + Tasks are now passed explicitly to operations that need them, so it + is now explicit which operations create commits. For example, the + API now makes it clear that `lcas` doesn't change anything, while + `lca` requires a task because it may create commits. + Apart from simplifying the code, this change also makes it possible to + create the internal stores once, not once per commit message. + Note: this does not affect the main BC API, so most users will see no + difference. +* Remove `Irmin.Basic`. This was a functor that took a functor for making + stores and returned a functor for making stores with strings for + branch names and SHA1 for the hash. It's easier to write the + application out in full than to explain to people what it does. + This change also makes it possible for back-ends to provide extra + operations in a type-safe way. In particular, `Irmin_git.Internals` + has moved inside the store type and the runtime check that it is only + used with the correct store type is now enforced at compile time + instead. +* Removed `AO.config`. It was only used by the removed `Git.Internals` hack. +* Moved `AO.create` to `AO_MAKER`. +* Remove dummy functions that are no longer needed with the new API: + - `View.task` is gone (it never did anything). + - `View.create` is gone (it ignored both its arguments and called `View.empty`). + - `Ir_node.Graph.Store.create` (unused, but previously required by `AO`). + - `Ir_commit.History.Store.create` (same). +* Removed the unused-and-not-exported `Ir_bc.Make` and `Ir_bc.MAKER` + features. +* Combine `Ir_bc.STORE_EXT` and `Ir_s.STORE`. `Ir_s` was the only + consumer of the `Ir_bc.STORE_EXT` interface, and all it did was repack + the values to match its own interface. Now, `Ir_bc` exports the final + public API directly, which simplifies the code. +* Moved module types into `ir_s.mli` and removed `ir_s.ml`. + Before, all module types were duplicated in the .ml and .mli files. +* `BC` stores now contain a `Repo` module. A `Repo.t` represents a + repository as a whole, rather than any particular branch. Operations + which do not look at the current branch have been moved to this + module. They are: `branches`, `remove_branch`, `heads`, + `watch_branches`, `import`, `export`, and `task_of_head`. + When updating old code, you can use `BC.repo t` to get a `Repo.t` + from a branch. + Note that `heads` previously ensured that the current branch's head was + included in the returned set (which made a difference for anonymous + branches). This feature has been removed. In the future, the plan is + to use OCaml's GC to track which anonymous branches are still being + used and return all of them. +* The internal stores (commit, node, etc) used to implement a full `BC` + store are now created by the back-ends, not by `Ir_bc`. This allows + back-ends to use their own APIs for this. In particular, back-ends + can now share resources (such as a database connection) between + stores. Internal stores no longer need to deal with `config` values + at all. +* `Sync.create` now takes a `Repo.t`, not a `config`, allowing + `Repo.config` to be removed and allowing sharing of the back-end's + internal state with the sync code. For example, the Git back-end + no longer needs to create a new Git store object for sync. +* Change `type head` to `type commit_id`. `head` was confusing because + it applied to all commits, not just branch heads. Putting `id` in the + name makes it clear that this is just data and (for example) holding + an ID will not prevent the corresponding commit from being GC'd (once + we have GC). `of_head` is now `of_commit_id`, `task_of_head` is now + `task_of_commit_id`, `Internals.commit_of_head` is now + `Internals.commit_of_id` and `BC.Head` is now `BC.Hash`. + +## 0.9.10 (2015-10-01) + +* Expose the Git compression level (#104, #298 by @samoht) +* Add an optional `config` argument to all the backend's config + functions. This allow the backends to composed more easily. (initial + patch by @nasrallahmounir, integration by @samoht) +* Add signatures for immutable link store, to store links between + keys: `Irmin.LINK` and `Irmin.LINK_MAKER`. Add `Irmin_mem.Link` and + `Irmin_fs.Link` which implement `Irmin.LINK_MAKER` in these backends + (initial patch by @nasrallahmounir, integration by @samoht) +* Add signatures for raw values (ie. whose values are of type + `Cstruct.t`): `Irmin.RAW` and raw store maker: `Irmin.AO_MAKER_RAW` + (initial patch by @nasrallahmounir, integration by @samoht) +* Expose `Irmin.Hash.digest_size` (initial patch by @nasrallahmounir, + integration by @samoht) +* Expose `/view` to the REST API (#292, by @samoht) +* Expose `Irmin.Private.merge_node` (#292 by @samoht) +* Change the JSON stream API, which requres ezjsonm.0.4.2. (#266, #269, + #273 by @samoht) +* Fix a race when a lot of processes are trying to add a watch at the + same time. (#270, #271, by @samoht) +* Expose `Irmin_git.Irmin_value_store` functor. This provides the + Irmin Contents/Node/Commit APIs on top of a Git-type store. This is + useful for backends that want to store data using the Git object + format, to be able to sync with Git, but without using Git's + filesystem layout and locking. (#268 by @talex5) +* Remove the first-class module API. It's confusing to duplicate the API + (#293, by @talex5) + +## 0.9.9 (2015-08-14) + +* Allow raw bodies in queries and responses for the REST API. This is + controlled by the `Content-type` field set by the client: + by default, we still use JSON (or use `application/json`) but using + `application/octet-stream` will avoid having to hex-encode large + binary blobs to make them JSON-compatible. This feature is still + experimental (especially when using Git on the server) (#255) +* Adapt to `ocaml-git.1.7.1` (which works with `lwt.2.5.0`) +* Expose `Store.config` for all the stores (`AO`, `RW`, etc.) +* Expose `Irmin_git.Internals` to be able to get back the + Git commit objects from an `head` value (#245, #241) +* Expose `Irmin.Private.remove_node` +* Remove the special `__root__` filename in Irmin stores and in views + (#233) + - This fixes `View.update_path` when the view contains a value at its + root. Now the updated path contains a the value stored at the root + of the view. + - Writing a value to the root of a store is now an error + - Reading a value at the root of a store always return `None` +* Make the HTTP backend re-raise the `Invalid_argument` and `Failure` + exceptions that were raised by the server. + +## 0.9.8 (2015-07-17) + +* Fix wrong interaction of in-memory views and temporary branches in the store + (#237) +* Fix `Irmin.update_tag` for HTTP clients +* Initial MirageOS support. Expose `Mirage_irmin.KV_RO` to surface an + Irmin store as a read-only key/value store implementing `V1_LWT.KV_RO + (#107) +* Expose `Irmin_git.Memory_ext. This allows the Git memory backend to be + configured with a non-empty conduit context. +* Expose `Irmin.SYNC` +* Transmit client tasks to the HTTP server on DELETE too (#227, @dsheets) +* Do note expose private types in the public interface (#234, @koleini) +* Fix missing zero padding for date pretty-printing (#228, @dsheets) +* Update the tests to use `ocaml-git.1.6.0` +* Improve the style of the HTTP commit graph. +* Constraint the string tags to contain only alpha-numeric characters + and few mores (`-`, `_`, '.' and `/`) (#186) +* Fix a race condition in `Irmin.clone`. (#221) +* Escpate double quotes in the output of commit messages to workaround + HTML display issues. (#222) + +## 0.9.7 (2015-07-06) + +* Add a version check for HTTP client and server. The client might add the + version in the HTTP headers using the `X-IrminVersion` header - the server + might decide to enfore the version check or not. The server always reply + with its version in the JSON reply, using a `version` field. The client + might use that information to bail out nicely instead of failing because + of some random unmarshalling errors due to API changes (#167) +* Fix a regression in 0.9.5 and 0.9.6 when inserting new child in Git trees. + This could cause a tree to have duplicate childs having the same names, + which would confuse the merge functions, make `git fsck` and `git gc` + complain a lot (with good reasons) and do some fency things with git + index. The regression has been introduced while trying to fix #190 (the fix + is in #229) + +## 0.9.6 (2015-07-03) + +* Fix the datamodel: it is not possible to store data in intermediate nodes + anymore (#209) +* Fix serialization of slices (#204) +* Do not fail silently when the synchronisation fails (#202) +* Fix a race in the HTTP backend between adding a watch and updating the store. + In some cases, the watch callback wasn't able to see the first few updates + (#198) +* Fix a race for all the on-disk backends between adding a watch and updating + the store. This is fixed by making `Irmin.Private.Watch.listen_dir` and + `Irmin.Private.Watch.set_listen_dir_hook` synchronous. +* Update the tests to use `alcotest >= 0.4`. This removes the dependency towards + `OUnit` and `nocrypto` for the tests. +* Make the file-locking code a bit more robust + +## 0.9.5 (2015-06-11) + +* Fix `Irmin.export` for the HTTP backend (#196, patch from Alex Zatelepin) +* Fix a race in `Irmin.export` (#196, patch from Alex Zatelepin) +* Add `Task.empty` (the empty task) and `Task.none` (the empty task constructor) +* Completely rewrite the notification mechanism. All the watch functions now + take a callback as argument and return a de-allocation function. The callbacks + receive a heads values (the last and current ones) and diff values. (#187) + - Add `Irmin.watch_head` to watch for the changes of the current branch's head + - Add `Irmin.watch_tags` to watch for the changes of all the tags in the store + - Add `Irmin.watch_key` to watch for the changes of the values associated to a + given key (this is not recursive anymore). + - Add `View.watch_path` to watch for the changes in a subtree. The function + return views and the user can use `View.diff` to compute differences between + views if needed. +* Transfer the HTTP client task to the server to make the commit messages + relative to the client state (and not the server's) (#136) +* Fix `View.remove` to clean-up empty directories (#190) +* Fix the ordering of tree entries in the Git backend (#190) +* Allow to create a new head from a view and a list of parents with + `View.make_head` (#188) +* Allow to create an empty temporary branch with `Irmin.empty` (#161) +* Use a pure OCaml implementation of SHA1, do not depend on nocrypto anymore + (#183, by @talex5) +* Remove `Irmin.Snapshot`. Nobody was using it and it can be easily replaced by + `Irmin.head`, `Irmin.watch_head` and `Irmin.update_head`. +* Change signature of `Irmin.iter` to include the values and move it into + the `Irmin.RO` signature. +* Add `Irmin.fast_forward_head` (#172) +* Add `Irmin.compare_and_set_head` (#171) +* Simplify the RW_MAKER signature (#158) +* Fix Irmin_git.RW_MAKER (#159) +* Improve the efficiency of the LCA computation (#174, with @talex5 help) +* By default, explore the full graph when computing the LCAs. The previous + behavior was to limit the depth of the exploration to be 256 by default. + +## 0.9.4 (2015-03-16) + +* Ensure that `Irmin.update` and `Irmin.merge` are atomic. +* Fix `Irmin.clone` of an empty branch +* Add `Irmin.RW.compare_and_test` that the backends now have to implement + to guarantee atomicity of Irmin's high-level operations. +* Add `Irmin.Private.Lock` to provide per-handler, per-key locking. This + can be used by backend to implement simple locking policies. +* Add `Lwt.t` to the return type of `Irmin.tag` and `Irmin.tag_exn` +* Do not throw [Not_found]. Now all the `_exn` function raise `Invalid_argument` + (#144) +* Remove `Irmin.switch` and `Irmin.detach` +* Add `Irmin.history` to get the branch history as a DAG of heads (#140). +* Fix performance of lcas computation (#160) +* Add `Irmin.Merge.promise` combinators + +## 0.9.3 (2015-01-04) + +* Fix the invalidation of the view caches (report by @gregtatcam). + This was causing some confusing issues where views' sub-keys where + not properly updated to to their new values when the view is merged + back to the store. The issues is a regression introduced in 0.9.0. +* Add post-commit hooks for the HTTP server. +* Add `Irmin.watch_tags` to monitor tag creation and desctructions. +* Fix `Irmin.push` +* Add `Irmin.with_hrw_view` to easily use transactions. +* Add a phantom type to `Irmin.t` to denote the store capabilities + read-only, read-write or branch-consistent. +* The `~old` argument of a merge function can now be optional to + signify that there is no common ancestor. +* Expose `Irmin.with_rw_view` to create a temporary, in-memory and + mutable view of the store. This can be used to perform atomic + operations in the store (ie. non-persistent transactions). +* Simplify the view API again +* Expose the task of previous commits. This let the user access + the Git timestamp and other info such as the committer name (#90) +* The user-defined merge functions now takes an `unit -> 'a result + Lwt.t` argument for `~old` (instead of `'a`). Evalutating the + function will compute the least-common ancestors. Merge functions + which ignore the `old` argument don't have to pay the cost of + computing the lcas anymore. +* Expose `S.lca` to get the least common ancestors +* Update to ocaml-git 1.4.6 + +## 0.9.2 (2015-01-19) + +* Fix `S.of_head` for the HTTP client (regression introduced in 0.9.0) +* Fix regression in displaying the store's graph over HTTP introduced by + 0.9.0. +* Fix regression in watch handling introduced in 0.9.0. +* Fix regressions in `Views` introduced in 0.9.0. (thx @buzzheavyyear for + the report) +* Always add a commit when calling a update function (`Irmin.update` + `Irmin.remove`, `Irmin.remove_rec`) even if the contents' store have + not changed. +* The [head] argument of [Git_unix.config] now has a proper type. +* Expose synchronisation functions for basic Irmin stores. +* The user-provided merge function now takes optional values. The + function is now called much more often during recursive merges + (even if one of the 3 buckets of the 3-way merge function is not + filled -- in that case, it uses `None`). +* Also expose the type of the keys in the type basic Irmin stores. Use + `('key, 'value) Irmint.t` instead of `'value Irmin.t`. +* The user-defined `merge` functions now take the current filename being + merged as an additional argument. +* The user-defined `Contents` should expose a `Path` sub-module. Keys of + the resulting Irmin store will be of type `Path.t`. +* Fix `irmin init --help`. (#103) + +## 0.9.1 (2014-12-26) + +* Port to Cohttp 0.14.0+ HTTP interface (#102) + +## 0.9.0 (2014-12-20) + +* Improve the efficiency of the Git backend +* Expose a cleaner API for the Unix backends +* Expose a cleaner public API +* Rename `Origin` into `Task` and use it pervasively through the API +* Expose a high-level REST API over HTTP (#80) +* Fix the Git backend to stop constantly overwrite `.git/HEAD` (#76) +* Add a limit on concurrently open files (#93, #75) +* Add `remove_rec` to remove directories (#74, #85) +* Remove dependency to `core_kernel` (#22, #81) +* Remove dependency to `cryptokit and `sha1` and use `nocrypto` instead +* Remove dependency to caml4 +* Fix writing contents at the root of the store (#73) +* More efficient synchronization protocol between Irmin stores (#11) + +## 0.8.3 (2014-06-25) + +* Views now keep track of their parent commits - this makes + View.merge_path looks like a merge between branches. All the + view operations are squashed in a unique commit. +* Better graphs, where we only show the commit history (the + full graph is still available using `--full` on the + command-lineor or `?full=1` on the web interface) +* By default, do not call `dot` when dumping a graph on the + command-line. `dot` does not like big graphs, but that's + still useful to have the `.dot` file to analyze it. + +## 0.8.2 (2014-06-11) + +* Support backend specific protocols for push/pull +* The Irmin Git backend can now sync with remote Git repositories +* Simplify the organisation of the libraries: irmin, irmin.backend, + irmin.server and irmin.unix (check how the example are compiled) +* Small refactoring to ease the use of the API. Now use `open Irmin_unix` + at the top of your file and use less functor in your code (again, + check the examples) + +## 0.8.1 (2014-06-02) + +* Fix the behavior of `IrminMemory.Make` to return an hanlder to a + shared datastore instead of creating a fresh one. Add + `IrminMemory.Fresh` to return a fresh in-memory datastore maker. +* The HTTP server now outputs some nice graph (using dagre-d3). Don't + expect to display very large graphs +* More friendly tag names in the Git backend (no need to prefix + everything by `refs/heads/` anymore) +* Partial support for recursive stores (WIP) + +## 0.8.0 (2014-05-27) + +* Spring clean-ups in the API. Separation in IrminBranch for + fork/join operations, IrminSnapshot for snapshot/revert + operations and IrminDump for import/export operations. + The later two implementation can be derived automaticaly + from a base IrminBranch implementation. The update and merge + operations are supported on each backend +* IrminGit does not depend on unix anymore and can thus be + compile to javascript or xen with mirage +* No need to have bin_io converter for contents anymore +* No need to have JSON converter for contents anymore +* No more IrminDispatch +* Add an optional branch argument to Irmin.create to use + an already existing branch +* Fix order of arguments in Irmin.merge + +## 0.7.0 (2014-05-02) + +* Feature: support for in-memory transactions. They are built + on top of views. +* Feature: add support for views: these are temporary stores with + lazy reads + in-memory writes; they can be used to convert back + and forth an OCaml value into a store, or to have a fast stagging + area without the need to commit every operation to the store. +* Support custom messages in commit messages +* Improve the IrminMerge API +* Backend: add a 'dispatch' backend for combining multiple backends + into one. This can be used to have a P2P store where there is + well-defined mapping between keys and host (as a DHT). +* Fix: limit the number of simulteanous open files in the Git and + the file-system backend +* Speed-up the in-memory store +* Speed-up the import/export codepath +* Speed-up the reads +* Speed-up IrminValue.Mux +* Deps: use ocaml-sha instead of cryptokit + +## 0.6.0 (2014-04-12) + +* Support for user-defined contents (with custom merge operators) +* Support for merge operations +* Rename `IrminTree` to `IrminNode` to reflect the fact that we + can support arbitrary immutable graphs (it's better if they are + DAGs but that's not mandatory) +* Rename `IrminBlob` to `IrminContents` to reflect the fact that + we also support structured contents (as JSON objects) +* Support for linking the library without linking to camlp4 as well (#23) + +## 0.5.1 (2014-03-02) + +* Port to use Cohttp 0.10.0 interface. + +## 0.5.0 (2014-02-21) + +* More consistent support for notifications. `irmin watch` works + now for all backends. +* Support for different blob formats on the command-line +* Support for JSON blobs +* More flexible `irmin fetch` command: we can now choose the backend to + import the data in +* Fix import of Git objects when the blobs were not imported first +* Support non-UTF8 strings as path name and blob contents (for all + backends, including the JSON one) +* Speed-up the `slow` tests execution time +* Improve the output graph when objects of different kinds might have + the same SHA1 + +## 0.4 (2014-01-21) + +* The command-line tool now looks in the environment for the variable + `IRMIN` to configure its default backend +* Add a Git backend +* Add Travis CI scripts to the repo +* Use `Lwt_bytes` and `Lwt_unix` instead of the custom-made `IrminChannel` +* Use `bin_prot` instead of a custom binary protocol +* Major refactoring: `Value` is now `Blob`, `Revision` is now `Commit` + and `Tag` becomes `Reference` (rational: consistency with Git names) +* Use `core_kernel` instead of building a custom `Identiable.S` +* Use `dolog` instead of a custom log library +* Use `mstruct` (mutable buffers on top of `cstruct`) which is now + released independently + +## 0.3 (2013-12-13) + +* Fix a fd leak in the filesystem bakend +* Functorize the CRUD interface over the HTTP client implementation +* Use oasis to build the project +* Use the now released separately `ezjsonm` and `alcotest` libraries + +## 0.2 (2013-11-23) + +* Fix the HTTP server responses +* More high-level tests +* Add unit-tests for the client CRUD interfaces (over memory and/or filesystem) +* Fix issues with the Tree API +* Implement a relatively efficent Import/Export scheme (#3) +* For more safety, the marshalled values are now typed in the binary protocol +* Add functions to dump the contents of the store as a Graphviz graph +* Polish the CLI which now looks usable enough +* Optimize the CRUD backend by executing high-level API functions on the server +* Improve and make the CLI easier to use +* Implement clone/pull/push/snapshot/revert in the CLI + +## 0.1 (2013-10-30) + +* Use an HTTP server as a front-end +* Initial support for in-memory and filesystem backends +* Simple signature for backends +* Binary protocol for storing values and metadata and for future network exchange diff --git a/vendors/irmin/CONTRIBUTING.md b/vendors/irmin/CONTRIBUTING.md new file mode 100644 index 0000000000000000000000000000000000000000..1b0460986744415a37181b04fe2a494d2f74a835 --- /dev/null +++ b/vendors/irmin/CONTRIBUTING.md @@ -0,0 +1,48 @@ +# Contribute to Irmin + +## License + +Irmin is distributed under the ISC license. Every OCaml source file +should start with a header comment instantiating the following +template (use appropriate comment syntax for other languages): + +``` +(* + * Copyright (c) [year(s)] [Holder ] + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) +``` + +Note that: + +- The holder, on the copyright line, is the name of individual + contributors and/or their company; +- When adding a significant new contribution to a file (i.e. more like + whole new features, rather than simple fixes), check whether there + already is a copyright for your copyright holder (see above): + - If there is one, mentioning any year, it is not required to add + the current year (but this is allowed). In no case should you + replace the existing year with the current one. + - If there is no line for your copyright holder, you should add one, + with the current year. + +For example, for a source file with multiple contributors spanning +several years, the copyright lines may look as follows: + +``` +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2018-2022 Tarides + * +``` diff --git a/vendors/irmin/LICENSE.md b/vendors/irmin/LICENSE.md new file mode 100644 index 0000000000000000000000000000000000000000..68422c3dbd6af459e9d6a28bdbf90c376619cf31 --- /dev/null +++ b/vendors/irmin/LICENSE.md @@ -0,0 +1,15 @@ +## ISC License + +Copyright (c) 2013-2017 Thomas Gazagnaire + +Permission to use, copy, modify, and distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. diff --git a/vendors/irmin/Makefile b/vendors/irmin/Makefile new file mode 100644 index 0000000000000000000000000000000000000000..10b1525273cfbe0c753333955e852044b005dc98 --- /dev/null +++ b/vendors/irmin/Makefile @@ -0,0 +1,26 @@ +.PHONY: all clean test fuzz bench-pack bench doc examples + +all: + dune build + +test: + dune runtest + +bench-pack-with-trace-replay: + @dune exec -- ./bench/irmin-pack/tree.exe --mode trace /home/opam/bench-dir/current-bench-data/mirage/irmin/tezos_actions_1commit.repr --ncommits-trace 12000 --artefacts ./cb_artefacts 1>&2 + @dune exec -- ./bench/irmin-pack/trace_stats.exe cb ./cb_artefacts/stat_summary.json + @rm -rf ./cb_artefacts + +bench: bench-pack-with-trace-replay + +fuzz: + dune build @fuzz --no-buffer + +examples: + dune build @examples + +clean: + dune clean + +doc: + dune build @doc diff --git a/vendors/irmin/README.md b/vendors/irmin/README.md new file mode 100644 index 0000000000000000000000000000000000000000..e838f71e4170ca28cee8cd00229d26c738a35486 --- /dev/null +++ b/vendors/irmin/README.md @@ -0,0 +1,193 @@ +
+ + Irmin logo + +
+ A Distributed Database Built on the Same Principles as Git +
+ +
+
+ +[![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https%3A%2F%2Fci.ocamllabs.io%2Fbadge%2Fmirage%2Firmin%2Fmain&logo=ocaml&style=flat-square)](https://ci.ocamllabs.io/github/mirage/irmin) +[![codecov](https://codecov.io/gh/mirage/irmin/branch/main/graph/badge.svg?token=n4mWfgURqT)](https://codecov.io/gh/mirage/irmin) +[![GitHub release (latest by date)](https://img.shields.io/github/v/release/mirage/irmin?style=flat-square&color=09aa89)](https://github.com/mirage/irmin/releases/latest) +[![docs](https://img.shields.io/badge/doc-online-blue.svg?style=flat-square)](https://mirage.github.io/irmin/) + +
+ +
+ +
+ + Irmin is an OCaml library for building mergeable, branchable distributed + data stores. + +
+ +## About + +- **Built-in Snapshotting** - backup and restore +- **Storage Agnostic** - you can use Irmin on top of your own storage layer +- **Custom Datatypes** - (de)serialization for custom data types, derivable via + [`ppx_irmin`][ppx_irmin-readme] +- **Highly Portable** - runs anywhere from Linux to web browsers and Xen unikernels +- **Git Compatibility** - `irmin-git` uses an on-disk format that can be + inspected and modified using Git +- **Dynamic Behavior** - allows the users to define custom merge functions, + use in-memory transactions (to keep track of reads as well as writes) and + to define event-driven workflows using a notification mechanism + +## Documentation + +API documentation can be found online at [https://mirage.github.io/irmin](https://mirage.github.io/irmin) + +## Installation + +### Prerequisites + +Please ensure to install the minimum `opam` and `ocaml` versions. Find the latest +version and install instructions on [ocaml.org](https://ocaml.org/docs/install.html). + +To install Irmin with the command-line tool and all unix backends using `opam`: + + +```bash + opam install irmin-cli +``` + +A minimal installation containing the reference in-memory backend can be +installed by running: + + +```bash + opam install irmin +``` + +The following packages have are available on `opam`: + +- `irmin` - the base package, plus an in-memory storage implementation +- `irmin-chunk` - chunked storage +- `irmin-cli` - a simple command-line tool +- `irmin-fs` - filesystem-based storage using `bin_prot` +- `irmin-git` - Git compatible storage +- `irmin-graphql` - GraphQL server +- `irmin-http` - a simple REST interface +- `irmin-mirage` - mirage compatibility +- `irmin-mirage-git` - Git compatible storage for mirage +- `irmin-mirage-graphql` - mirage compatible GraphQL server +- `irmin-pack` - compressed, on-disk, posix backend +- `ppx_irmin` - PPX deriver for Irmin content types (see [README_PPX.md][ppx_irmin-readme]) +- `irmin-containers` - collection of simple, ready-to-use mergeable data structures + +To install a specific package, simply run: + + +```bash + opam install +``` + +### Development Version + +To install the development version of Irmin in your current `opam switch`, clone +this repository and `opam install` the packages inside: + + +```bash + git clone https://github.com/mirage/irmin + cd irmin/ + opam install . +``` + +## Usage + +### Example + +Below is a simple example of setting a key and getting the value out of a +Git-based, filesystem-backed store. + + +```ocaml +open Lwt.Syntax + +(* Irmin store with string contents *) +module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) + +(* Database configuration *) +let config = Irmin_git.config ~bare:true "/tmp/irmin/test" + +(* Commit author *) +let author = "Example " + +(* Commit information *) +let info fmt = Irmin_git_unix.info ~author fmt + +let main = + (* Open the repo *) + let* repo = Store.Repo.v config in + + (* Load the main branch *) + let* t = Store.main repo in + + (* Set key "foo/bar" to "testing 123" *) + let* () = + Store.set_exn t ~info:(info "Updating foo/bar") [ "foo"; "bar" ] + "testing 123" + in + + (* Get key "foo/bar" and print it to stdout *) + let+ x = Store.get t [ "foo"; "bar" ] in + Printf.printf "foo/bar => '%s'\n" x + +(* Run the program *) +let () = Lwt_main.run main +``` + +The example is contained in [examples/readme.ml](./examples/readme.ml) It can +be compiled and executed with dune: + + +```bash +$ dune build examples/readme.exe +$ dune exec examples/readme.exe +foo/bar => 'testing 123' +``` + +The [examples](./examples/) directory also contains more advanced examples, +which can be executed in the same way. + +### Command-line + +The same thing can also be accomplished using `irmin`, the command-line +application installed with `irmin-cli`, by running: + +```bash +$ echo "root: ." > irmin.yml +$ irmin init +$ irmin set foo/bar "testing 123" +$ irmin get foo/bar +testing 123 +``` + +`irmin.yml` allows for `irmin` flags to be set on a per-directory basis. You +can also set flags globally using `$HOME/.irmin/config.yml`. Run +`irmin help irmin.yml` for further details. + +Also see `irmin --help` for list of all commands and either +`irmin --help` or `irmin help ` for more help with a +specific command. + +## Issues + +Feel free to report any issues using the [GitHub bugtracker](https://github.com/mirage/irmin/issues). + +## License + +See the [LICENSE file](./LICENSE.md). + +## Acknowledgements + +Development of Irmin was supported in part by the EU FP7 User-Centric Networking +project, Grant No. 611001. + +[ppx_irmin-readme]: ./README_PPX.md diff --git a/vendors/irmin/README_LIBIRMIN.md b/vendors/irmin/README_LIBIRMIN.md new file mode 100644 index 0000000000000000000000000000000000000000..1fcd7148fd3f3bae26d481d2992c5961375bdbdf --- /dev/null +++ b/vendors/irmin/README_LIBIRMIN.md @@ -0,0 +1,173 @@ +# libirmin + +`libirmin` provides C bindings to the irmin API. + +## Installation + +To install from the root of this repo: + +``` +$ opam pin add libirmin . +``` + +After installing `libirmin.so` can be found in `$OPAM_SWITCH_PREFIX/libirmin/lib` +and `irmin.h` will be in `$OPAM_SWITCH_PREFIX/libirmin/include` + +This means when compiling programs that use `libirmin` you will need to include those +directories: + +``` +$ export IRMIN_CFLAGS=-I$OPAM_SWITCH_PREFIX/libirmin/include +$ export IRMIN_LDFLAGS=-L$OPAM_SWITCH_PREFIX/libirmin/lib -lirmin +$ cc $IRMIN_CFLAGS my-program.c -o my-program $IRMIN_LDFLAGS +``` + +## Usage examples + +### Opening a store + +The first thing you will need to do is configure a backend: + +Using `irmin-git`: + +```c +IrminConfig *config = irmin_config_git("string"); +if (config == NULL){ + // Print error message + IrminString *err = irmin_error_msg(); + fputs(irmin_string_data(err), stderr); + irmin_string_free(err); +} +``` + +When using `irmin-mem`, `irmin-fs` or `irmin-pack` you can specify the hash type +in addition to the content type: + +```c +IrminConfig *config = irmin_config_mem("sha256", "string"); +``` + +Available backends: `irmin_config_mem`, `irmin_config_git`, `irmin_config_git_mem`, `irmin_config_fs`, +`irmin_config_pack`, `irmin_config_tezos` + +If `NULL` is passed for the content parameter then `string` will be used by default and +when `NULL` is passed for the hash argument `blake2b` is used. + +Available content types: `string`, `json` (JSON objects), `json-value` (any JSON value) +Available hash types: `blake2b`, `blake2s`, `rmd160`, `sha1`, `sha224`, `sha256`, `sha384`, +`sha512`, `tezos` + +The `IrminConfig*` value should eventually be freed using `irmin_config_free`. + +When using a backend that stores information on disk, you will probably want to set the `root` parameter: + +```c +assert(irmin_config_set_root(config, "path/to/store")); +``` + +Next you can initialize the repo: + +```c +IrminRepo *repo = irmin_repo_new(config); +if (repo == NULL){ + // handle error +} +``` + +From there you can create a store using the main branch: + +```c +Irmin *store = irmin_main(repo); +``` + +Or from your branch of choice: + +```c +Irmin *store = irmin_of_branch(repo, "my-branch"); +``` + +### Cleanup + +Every `IrminX` type should be released using the matching `irmin_X_free` function: + +```c +irmin_free(store); +irmin_repo_free(repo); +irmin_config_free(config); +``` + +### Setting values + +Setting a value when using string contents: + +```c +IrminString *value = irmin_string_new("Hello, world!", -1); +IrminPath *path = irmin_path_of_string(repo, "a/b/c"); +IrminInfo *info = irmin_info_new(repo, "author", "commit message"); +assert(irmin_set(store, path, (IrminContents*)value, info)); +irmin_info_free(info); +irmin_path_free(path); +irmin_string_free(value); +``` + +The `-1` argument to `irmin_string_new` is used to pass the length of +the string. If it ends with a NULL byte then passing `-1` will auto- +matically detect the string length. This also shows that `IrminString` +can be cast to `IrminContents` safely when using `string` contents. + +When using `json` contents: + +```c +IrminType *t = irmin_type_json(); +IrminContents *value = irmin_contents_of_string(t, "{\"foo\": \"bar\"}", -1); +IrminPath *path = irmin_path_of_string(repo, "a/b/c"); +IrminInfo *info = irmin_info_new(repo, "author", "commit message"); +assert(irmin_set(store, path, value, info)); +irmin_info_free(info); +irmin_path_free(path); +irmin_contents_free(value); +irmin_type_free(t); +``` + +### Getting values + +The following will get the value associated with a path and print its string +representation to stdout: + +```c +IrminPath *path = irmin_path_of_string(repo, "a/b/c"); +IrminContents *value = irmin_find(store, path); +if (value != NULL){ + // value exists, print it to stdout + IrminString *s = irmin_contents_to_string(repo, value); + puts(irmin_string_data(s)); + irmin_string_free(s); + irmin_contents_free(value); +} +irmin_path_free(path); +``` + +### Trees + +Working with trees is similar to working with stores, only you will be using the +`irmin_tree_X` functions: + +```c +IrminTree *tree = irmin_tree_new(repo); +IrminString *value = irmin_string_new("Hello, world!", -1); +IrminPath *path = irmin_path_of_string(repo, "a/b/c"); +assert(irmin_tree_add(tree, path, value, NULL); // The NULL parameter here is for + // metadata and will typically be + // NULL + +IrminPath *empty_path = irmin_path_empty(); +IrminInfo *info = irmin_info_new(repo, "author", "commit message"); +irmin_set_tree(store, empty_path, tree, info); + +irmin_string_free(value); +irmin_path_free(path); +irmin_path_free(empty_path); +irmin_info_free(info); +irmin_tree_free(tree); +``` + diff --git a/vendors/irmin/README_PPX.md b/vendors/irmin/README_PPX.md new file mode 100644 index 0000000000000000000000000000000000000000..ce86a66387475ce1e15e73bbc4decdad73fc1f67 --- /dev/null +++ b/vendors/irmin/README_PPX.md @@ -0,0 +1,128 @@ +## ppx_irmin + +PPX extension for automatically generating Irmin type representations. + +### Overview + +`ppx_irmin` automatically generates Irmin type representations (values of type +`_ Irmin.Type.t`) corresponding to type declarations in your code. For example: + +```ocaml +type 'a tree = + | Branch of tree * bool option * tree + | Leaf of 'a [@@deriving irmin] +``` + +will be expanded to: + +```ocaml +type 'a tree = (* as above *) + +let tree_t leaf_t = + let open Irmin.Type in + mu (fun tree_t -> + variant "tree" (fun branch leaf -> function + | Branch (x1, x2, x3) -> branch (x1, x2, x3) + | Leaf (x1, x2) -> leaf (x1, x2)) + |~ case1 "Branch" (triple tree_t (option bool) tree_t) (fun (x1, x2, x3) -> Branch (x1, x2, x3)) + |~ case1 "Leaf" leaf_t (fun x1 -> Leaf x1) + |> sealv) +``` + +Type representations can also be derived inline using the `[%typ: ]` +extension point. + +### Installation and usage + +`ppx_irmin` may be installed via [opam](https://opam.ocaml.org/): + +``` +opam install ppx_irmin +``` + +If you're using the [dune](https://github.com/ocaml/dune) build system, add the +following field to your `library`, `executable` or `test` stanza: + +``` +(preprocess (pps ppx_irmin)) +``` + +You can now use `[@@deriving irmin]` after a type declaration in your code to +automatically derive an Irmin type representation with the same name. + +### Specifics + +`ppx_irmin` supports all of the type combinators exposed in the +[Irmin.Type](https://docs.mirage.io/irmin/Irmin/Type/index.html) module (basic +types, records, variants (plain and closed polymorphic), recursive types etc.). +Types with parameters will result in parameterised representations (i.e. type +`'a t` is generated a representation of type `'a Type.t -> 'a t Type.t`). + +To supply base representations from a module other than `Irmin.Type` (such as +when `Irmin.Type` is aliased to a different module path), the `lib` argument +can be passed to `@@deriving irmin`: + +```ocaml +type foo = unit [@@deriving irmin { lib = Some "Mylib.Types" }] + +(* generates the value *) +val foo_t = Mylib.Types.unit +``` + +This argument can also be passed as a command-line option (i.e. `--lib +Mylib.Types`, with `--lib ''` interpreted as the current module). + +#### Naming scheme + +The generated type representation will be called `_t`, unless the +type-name is `t`, in which case the representation is simply `t`. This +behaviour can be overridden using the `name` argument, as in: + +```ocaml +type foo = string list * int32 [@@deriving irmin { name = "foo_repr" }] + +(* generates the value *) +val foo_repr = Irmin.Type.(pair (list string) int32) +``` + +If the type contains an abstract type, `ppx_irmin` will expect to find a +corresponding type representation using its own naming rules. This can be +overridden using the `[@repr ...]` attribute, as in: + +```ocaml +type bar = (foo [@repr foo_repr], string) result [@@deriving irmin] + +(* generates the value *) +val bar_t = Irmin.Type.(result foo_repr string) +``` + +Built-in abstract types such as `unit` are assumed to be represented in +`Irmin.Type`. This behaviour can be overridden with the `[@nobuiltin]` +attribute: + +```ocaml +type t = unit [@nobuiltin] [@@deriving irmin] + +(* generates the value *) +let t = unit_t (* not [Irmin.Type.unit] *) +``` + +#### Signature type definitions + +The `ppx_irmin` deriver can also be used in signatures to expose the +auto-generated value: + +```ocaml +module Contents : sig + type t = int32 [@@deriving irmin] + + (* exposes repr in signature *) + val t : t Irmin.Type.t + +end = struct + type t = int32 [@@deriving irmin] + + (* generates repr value *) + let t = Irmin.Type.int32 +end +``` diff --git a/vendors/irmin/RELEASE.md b/vendors/irmin/RELEASE.md new file mode 100644 index 0000000000000000000000000000000000000000..5e66ffee0c778e04b3c04348ccd81d1448dfea48 --- /dev/null +++ b/vendors/irmin/RELEASE.md @@ -0,0 +1,181 @@ +# Release process + +This file documents the necessary steps for releasing Irmin to its various users +(via GitHub, `opam-repository` and Tezos). + +At a high level, releasing Irmin consists of publishing the following artefacts: + +- a Git [commit tag][git-tags]; +- a set of documentation on GitHub pages (e.g. [`mirage.github.io/irmin`][pages-docs]); +- a release archive (`.tbz` file containing the project source) on GitHub; +- a set of `.opam` files in [`opam-repository`][opam-repo] that point to this + release archive; +- (optionally) a copy of these `.opam` files in the Tezos + [`opam-repository`][tezos-opam-repo]. + +Most of this can be handled automatically by [`dune-release`][dune-release], as +described in the instructions below. + +[git-tags]: https://git-scm.com/book/en/v2/Git-Basics-Tagging +[pages-docs]: https://mirage.github.io/irmin +[dune-release]: https://github.com/ocamllabs/dune-release +[opam-repo]: https://github.com/ocaml/opam-repository + + +## Manual benchmarking + +Before releasing, it is important to make sure that the new version doesn't +induce performance regressions. The trace replay benchmarks should be used +for that purpose. + +The performances of individual releases of irmin are saved inside the +benchmarking server at `/bench/releases/`: +``` +. +└── ncommits_200k + ├── irmin2.7.0_index1.4.0_repr0.4.0 + │   ├── packet_b + │   │   ├── stat_summary.json + │   │   └── stat_trace.repr + │   └── packet_a + │   ├── stat_summary.json + │   └── stat_trace.repr + ├── irmin2.5.4_index1.3.1_repr0.3.0 + │   ├── packet_b + │   │   ├── stat_summary.json + │   │   └── stat_trace.repr + │   └── packet_a + │   ├── stat_summary.json + │   └── stat_trace.repr + └── irmin2.2.0_index1.2.1 +    ├── packet_b +    │   ├── stat_summary.json +    │   └── stat_trace.repr +    └── packet_a +    ├── stat_summary.json +    └── stat_trace.repr +``` + +To test a new release, setup an `c3-small-x86-01` Equinix instance, fetch a large +enough replay trace and setup the right versions of the right libraries +before running the benchmarks. + +The benchmark should be run at least twice (to give insights about the noise), +the two resulting `stat_trace.repr` files should be copied to +`/bench/releases/` using the same naming convention as above. Also set the file +permissions to read-only using `chmod 444 stat_trace.repr`. + +A run of the benchmark is expected to last \~35min. + +See [this script](https://github.com/tarides/irmin-tezos/blob/master/bench.sh) for an example of a setup and a bench run. + +### Visualising the results + +A `stat_summary.json` can be computed from a `stat_trace.repr`. + +If missing or out of date (resulting in a parsing error), the JSON can be +(re)generated using the following commands: +``` +dune exec -- bench/irmin-pack/trace_stats.exe summarise stat_trace.repr >stat_summary.json +``` + +A conversion is expected to last \~4 min. + +One or more summaries can be pretty printed together. The following command +will pretty print both runs of 2 releases side by side: +```sh +; export ROOT='/bench/releases/ncommits_200k/irmin2.7.0_index1.4.0_repr0.4.0/' +; export ROOT_OLD='/bench/releases/ncommits_200k/irmin2.2.0_index1.2.1/' +; dune exec -- bench/irmin-pack/trace_stats.exe pp \ + -f old,$ROOT_OLD/packet_a/stat_summary.json \ + -f old,$ROOT_OLD/packet_b/stat_summary.json \ + -f old,$ROOT/packet_a/stat_summary.json \ + -f old,$ROOT/packet_b/stat_summary.json +``` + +See [this script](https://github.com/tarides/irmin-tezos/blob/master/summarise.sh) for an example of a batch conversion to JSON. + +## Releasing to opam-repository and GitHub + +- Check that no `.opam` files contain `pin-depends` fields. If so, release those + packages first. + +```sh +; git grep -A 10 "pin-depends" *.opam +``` + +- Make a pull-request to this repository containing pre-release changes (drop + `pin-depends`, add release number to `CHANGES.md`, any new constraints) and an + empty commit to host the release tag. + +```sh +; git fetch upstream +; git checkout -B release-X.Y.Z upstream/main +; git commit -m "Prepare X.Y.Z release" -- CHANGES.md +; git commit --allow-empty -m "Release X.Y.Z" +; hub pull-request +``` + +- Wait for the CI to pass on the release PR, then perform the following steps to + release to `opam-repository`: + +```sh +; opam upgrade odoc # Use the latest Odoc + +; dune-release tag # Create appropriate Git tag by reading CHANGES.md +; dune-release distrib --skip-tests # Build release archive +; dune-release publish distrib --verbose # Push release archive to GitHub +; dune-release publish doc --verbose # Push documentation to GitHub pages +; dune-release opam pkg # Generate `opam` files for `opam-repository` +; dune-release opam submit # Make PR to `opam-repository` +``` + +- Once the release PR is merged on `opam-repository`, merge the release PR on + the development repository. If any changes to `.opam` files were necessary in + the `opam-repository` PR, add those to the release PR before merging. + +### Re-cutting a failed Opam release + +It may be necessary to re-cut an attempted release, for instance if the +`opam-repository` CI raised issues that couldn't be fixed via if the +`opam-repository`. + +First delete the release distribution via the GitHub UI, then cleanup the Git +tags and re-perform the required release steps: + +```sh +; git tag -d X.Y.Z # Erase git tag locally +; git push -d upstream X.Y.Z # Erase git tag on GitHib +; dune-release distrib --skip-tests +; dune-release publish distrib --verbose +; dune-release publish doc --verbose # ... if necessary +; dune-release opam pkg +; dune-release opam submit ^C # Exit at prompt to avoid creating pull request +; cd +; git push -u origin --force # Add new `.opam` files to PR +``` + +## Releasing to Tezos' opam-repository + +The Tezos project uses [its own `opam-repository`][tezos-opam-repo] to source +its dependencies, so upgrading its dependencies requires making a separate +release to this _after_ having released to the main `opam-repository`. The +process is as follows: + +```sh +for p in ; do + # Remove old version of this package from Tezos' opam-repository + rm ~/t/tezos-opam-repository/packages/$p/*/ -rf + + # Copy opam file for the new release of this package + cp ~/t/{opam-repository,tezos-opam-repository}/packages/$p/$p. -r +done +``` + +(The above process is somewhat automated by [this +script][tezos-downstream-script].) Once this is done, make an MR to the Tezos +opam-repository and – if necessary – a corresponding MR to Tezos to adjust to +any API changes. + +[tezos-opam-repo]: https://gitlab.com/tezos/opam-repository +[tezos-downstream-script]: https://github.com/CraigFe/dotfiles/blob/main/scripts/.scripts/tezos-downstream diff --git a/vendors/irmin/bench/irmin-pack/_layers.mli b/vendors/irmin/bench/irmin-pack/_layers.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/_layers.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/bench/irmin-pack/bench_common.ml b/vendors/irmin/bench/irmin-pack/bench_common.ml new file mode 100644 index 0000000000000000000000000000000000000000..d50976b5b49387ce44e71122ca35ad48cc0c75e1 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/bench_common.ml @@ -0,0 +1,185 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Export_for_backends + +let now_s () = Mtime.Span.to_s (Mtime_clock.elapsed ()) + +let reporter ?(prefix = "") () = + let report src level ~over k msgf = + let k _ = + over (); + k () + in + let ppf = match level with Logs.App -> Fmt.stdout | _ -> Fmt.stderr in + let with_stamp h _tags k fmt = + let dt = now_s () in + Fmt.kpf k ppf + ("%s%+04.0fus %a %a @[" ^^ fmt ^^ "@]@.") + prefix dt Logs_fmt.pp_header (level, h) + Fmt.(styled `Magenta string) + (Logs.Src.name src) + in + msgf @@ fun ?header ?tags fmt -> with_stamp header tags k fmt + in + { Logs.report } + +let setup_log style_renderer level = + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (reporter ()); + () + +let reset_stats () = + Index.Stats.reset_stats (); + Irmin_pack.Stats.reset_stats () + +let random_char () = char_of_int (Random.int 256) +let random_string n = String.init n (fun _i -> random_char ()) +let random_blob () = random_string 10 |> Bytes.of_string +let random_key () = random_string 5 + +let default_artefacts_dir = + let ( / ) = Filename.concat in + Unix.getcwd () / "_artefacts" / Uuidm.to_string (Uuidm.v `V4) + +let prepare_artefacts_dir path = + let rec mkdir_p path = + if Sys.file_exists path then () + else + let path' = Filename.dirname path in + if path' = path then failwith "Failed to prepare result dir"; + mkdir_p path'; + Unix.mkdir path 0o755 + in + mkdir_p path + +let with_timer f = + let t0 = Sys.time () in + let+ a = f () in + let t1 = Sys.time () -. t0 in + (t1, a) + +let with_progress_bar ~message ~n ~unit = + let open Progress in + let config = + Config.v ~max_width:(Some 79) ~min_interval:(Some Duration.(of_sec 0.5)) () + in + let bar = + Line.( + list + [ + const message; + count_to n; + const unit; + elapsed (); + parens (const "ETA: " ++ eta n); + bar n; + percentage_of n; + ]) + in + with_reporter ~config bar + +module Conf = Irmin_tezos.Conf + +module Schema = struct + open Irmin + module Metadata = Metadata.None + module Contents = Contents.String + module Path = Path.String_list + module Branch = Branch.String + module Hash = Hash.SHA1 + module Node = Node.Make (Hash) (Path) (Metadata) + module Commit = Commit.Make (Hash) + module Info = Info.Default +end + +module Info (I : Irmin.Info.S) = struct + let f () = I.v ~author:"tests" ~message:"commit" 0L +end + +module FSHelper = struct + let file f = + try (Unix.stat f).st_size with Unix.Unix_error (Unix.ENOENT, _, _) -> 0 + + let dict root = file (Irmin_pack.Layout.V1_and_v2.dict ~root) / 1024 / 1024 + let pack root = file (Irmin_pack.Layout.V1_and_v2.pack ~root) / 1024 / 1024 + + let index root = + let index_dir = Filename.concat root "index" in + let a = file (Filename.concat index_dir "data") in + let b = file (Filename.concat index_dir "log") in + let c = file (Filename.concat index_dir "log_async") in + (a + b + c) / 1024 / 1024 + + let size root = dict root + pack root + index root + let get_size root = size root + + let rm_dir root = + if Sys.file_exists root then ( + let cmd = Printf.sprintf "rm -rf %s" root in + [%logs.info "exec: %s" cmd]; + let _ = Sys.command cmd in + ()) +end + +module Generate_trees + (Store : Irmin.Generic_key.KV with type Schema.Contents.t = bytes) = +struct + let key depth = + let rec aux i acc = + if i >= depth then acc + else + let k = random_key () in + aux (i + 1) (k :: acc) + in + aux 0 [] + + let chain_tree tree depth path = + let k = path @ key depth in + Store.Tree.add tree k (random_blob ()) + + let add_chain_trees depth nb tree = + let path = key 2 in + let rec aux i tree = + if i >= nb then Lwt.return tree + else + let* tree = chain_tree tree depth path in + aux (i + 1) tree + in + aux 0 tree + + let large_tree path tree width = + let rec aux i tree = + if i >= width then Lwt.return tree + else + let k = path @ [ random_key () ] in + let* tree = Store.Tree.add tree k (random_blob ()) in + aux (i + 1) tree + in + aux 0 tree + + let add_large_trees width nb tree = + let path = key 1 in + let rec aux i tree = + if i >= nb then Lwt.return tree + else + let path = path @ [ random_key () ] in + let* tree = large_tree path tree width in + aux (i + 1) tree + in + aux 0 tree +end diff --git a/vendors/irmin/bench/irmin-pack/bench_common.mli b/vendors/irmin/bench/irmin-pack/bench_common.mli new file mode 100644 index 0000000000000000000000000000000000000000..9f2cf0335b3f95c71dac100fd68fcab012571cc6 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/bench_common.mli @@ -0,0 +1,50 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val default_artefacts_dir : string +val prepare_artefacts_dir : string -> unit +val reporter : ?prefix:string -> unit -> Logs.reporter +val setup_log : Fmt.style_renderer option -> Logs.level option -> unit +val reset_stats : unit -> unit +val with_timer : (unit -> 'a Lwt.t) -> (float * 'a) Lwt.t + +val with_progress_bar : + message:string -> n:int -> unit:string -> ((int -> unit) -> 'a) -> 'a + +val random_blob : unit -> bytes + +module Info (I : Irmin.Info.S) : sig + val f : I.f +end + +module Conf : Irmin_pack.Conf.S +module Schema : Irmin.Schema.S + +module FSHelper : sig + val rm_dir : string -> unit + val get_size : string -> int +end + +module Generate_trees + (Store : Irmin.Generic_key.KV with type Schema.Contents.t = bytes) : sig + val add_chain_trees : int -> int -> Store.tree -> Store.tree Lwt.t + (** [add_chain_trees depth nb tree] adds [nb] random contents to [tree], + depthwise. *) + + val add_large_trees : int -> int -> Store.tree -> Store.tree Lwt.t + (** [add_large_trees width nb tree] adds [nb] random contents to [tree], + breadthwise. *) +end diff --git a/vendors/irmin/bench/irmin-pack/dune b/vendors/irmin/bench/irmin-pack/dune new file mode 100644 index 0000000000000000000000000000000000000000..b95a7cc624603041b9b2ce2167cf3ace0b33fba1 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/dune @@ -0,0 +1,94 @@ +(executables + (names main) + (public_names bench-pack) + (modules main import) + (package irmin-bench) + (preprocess + (pps ppx_irmin.internal ppx_repr)) + (libraries + irmin-pack + irmin-test.bench + lwt + unix + cmdliner + logs + repr + ppx_repr + bench_common + mtime + rusage)) + +(library + (name bench_common) + (public_name irmin-bench.common) + (modules bench_common) + (libraries irmin-pack irmin-pack.unix irmin-tezos unix progress uuidm) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) + +(library + (name irmin_traces) + (public_name irmin-bench.traces) + (modules + trace_common + trace_definitions + trace_collection + trace_stat_summary + trace_stat_summary_conf + trace_stat_summary_utils + trace_stat_summary_pp + trace_replay + trace_replay_intf + tezos_history_metrics + trace_stat_summary_cb) + (preprocess + (pps ppx_irmin.internal ppx_repr ppx_deriving.enum)) + (libraries + irmin + irmin-pack + unix + lwt + repr + ppx_repr + bentov + mtime + printbox + printbox-text + mtime.clock.os + bench_common) + (instrumentation + (backend bisect_ppx))) + +(executable + (name tree) + (modules tree) + (preprocess + (pps ppx_irmin.internal ppx_repr)) + (libraries + irmin-pack + irmin-pack.mem + irmin-test.bench + lwt + unix + cmdliner + logs + repr + ppx_repr + bench_common + irmin-tezos + irmin_traces)) + +(executable + (name trace_stats) + (modules trace_stats) + (libraries cmdliner irmin_traces)) + +;; Require the executables to compile during tests + +(rule + (alias runtest) + (package irmin-bench) + (deps main.exe tree.exe trace_stats.exe) + (action (progn))) diff --git a/vendors/irmin/bench/irmin-pack/import.ml b/vendors/irmin/bench/irmin-pack/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..2fed488f984d94afe2952e6353640928e3e5d132 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/import.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/bench/irmin-pack/main.ml b/vendors/irmin/bench/irmin-pack/main.ml new file mode 100644 index 0000000000000000000000000000000000000000..828480924ff2dc5e548bdcecd54301cd01fce747 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/main.ml @@ -0,0 +1,55 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let config ~root = Irmin_pack.config ~fresh:false root + +module Config = struct + let entries = 2 + let stable_hash = 3 + let contents_length_header = Some `Varint + let inode_child_order = `Hash_bits + let forbid_empty_dir_persistence = false +end + +module KV = struct + module Maker = Irmin_pack_unix.KV (Config) + include Maker.Make (Irmin.Contents.String) +end + +module Bench = Irmin_bench.Make (KV) + +let file f = + (* in MiB *) + try (Unix.stat f).st_size / 1024 / 1024 + with Unix.Unix_error (Unix.ENOENT, _, _) -> 0 + +let index root = + let rec aux acc i = + if i = 256 then acc + else + let filename = Format.sprintf "store.index.%d" i in + let s = file (Filename.concat root filename) in + aux (acc + s) (i + 1) + in + aux 0 0 + +let size ~root = + let index_size = index root in + Irmin_pack.Layout.V1_and_v2.all ~root + |> List.map file + |> List.fold_left ( + ) index_size + +let () = Bench.run ~config ~size diff --git a/vendors/irmin/bench/irmin-pack/main.mli b/vendors/irmin/bench/irmin-pack/main.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/main.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/bench/irmin-pack/tezos_history_metrics.ml b/vendors/irmin/bench/irmin-pack/tezos_history_metrics.ml new file mode 100644 index 0000000000000000000000000000000000000000..2078a1e743d3fd358e990c5ec44c9cb2f1f8b969 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/tezos_history_metrics.ml @@ -0,0 +1,178 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** List of tuples of week timestamp, week transaction count, week ops count and + week block count. + + There is ~1 block per minute in tezos and 10080 minutes in a week. Hence the + content of the last columns. + + Computed using: + + https://api.tzstats.com/series/block.json?collapse=1w&columns=n_tx,n_ops,count *) +let weekly_stats = + [ + (1529884800000, 497, 16396, 1814); + (1530489600000, 10337, 103366, 10031); + (1531094400000, 6444, 24425, 8478); + (1531699200000, 6268, 41311, 9674); + (1532304000000, 4423, 126915, 9916); + (1532908800000, 3951, 153091, 9561); + (1533513600000, 3709, 151066, 9088); + (1534118400000, 5103, 164351, 9442); + (1534723200000, 7744, 174163, 9504); + (1535328000000, 16856, 196819, 9627); + (1535932800000, 9080, 195198, 9756); + (1536537600000, 11296, 200613, 9759); + (1537142400000, 34291, 234489, 9935); + (1537747200000, 11029, 203505, 9657); + (1538352000000, 15221, 211566, 9718); + (1538956800000, 12279, 212965, 9857); + (1539561600000, 16400, 216941, 9706); + (1540166400000, 17277, 224464, 9875); + (1540771200000, 13674, 219879, 9855); + (1541376000000, 17780, 222633, 9781); + (1541980800000, 43862, 243942, 9582); + (1542585600000, 265754, 552326, 8583); + (1543190400000, 29911, 199036, 8446); + (1543795200000, 46262, 255443, 9395); + (1544400000000, 46809, 265757, 9433); + (1545004800000, 17226, 223122, 9601); + (1545609600000, 14758, 224245, 9671); + (1546214400000, 20025, 234288, 9775); + (1546819200000, 15696, 227917, 9667); + (1547424000000, 20349, 235370, 9743); + (1548028800000, 17173, 232767, 9725); + (1548633600000, 17551, 234505, 9714); + (1549238400000, 22169, 241307, 9741); + (1549843200000, 17892, 239578, 9787); + (1550448000000, 17899, 239569, 9784); + (1551052800000, 23444, 244467, 9749); + (1551657600000, 17721, 236558, 9666); + (1552262400000, 24563, 247532, 9743); + (1552867200000, 22835, 250750, 9835); + (1553472000000, 23011, 251950, 9845); + (1554076800000, 29518, 257341, 9739); + (1554681600000, 21775, 246456, 9683); + (1555286400000, 30670, 257784, 9771); + (1555891200000, 27023, 251536, 9687); + (1556496000000, 22465, 248722, 9767); + (1557100800000, 32423, 259129, 9773); + (1557705600000, 27606, 258295, 9859); + (1558310400000, 24614, 252204, 9771); + (1558915200000, 32625, 248919, 9520); + (1559520000000, 26519, 251351, 9736); + (1560124800000, 32499, 258754, 9683); + (1560729600000, 33250, 257565, 9578); + (1561334400000, 29034, 252155, 9611); + (1561939200000, 37005, 260170, 9597); + (1562544000000, 31342, 255413, 9618); + (1563148800000, 27970, 250786, 9563); + (1563753600000, 43176, 273231, 9702); + (1564358400000, 31888, 268034, 9877); + (1564963200000, 38565, 272631, 9781); + (1565568000000, 40317, 269809, 9669); + (1566172800000, 32076, 266277, 9802); + (1566777600000, 36307, 269958, 9789); + (1567382400000, 35313, 263821, 9683); + (1567987200000, 30223, 264633, 9799); + (1568592000000, 38428, 276965, 9913); + (1569196800000, 38314, 279131, 9914); + (1569801600000, 42121, 282076, 9921); + (1570406400000, 32572, 272638, 9900); + (1571011200000, 33358, 261102, 9723); + (1571616000000, 52981, 280392, 9812); + (1572220800000, 40154, 270988, 9876); + (1572825600000, 61329, 296468, 9889); + (1573430400000, 40552, 262779, 9608); + (1574035200000, 39421, 264409, 9742); + (1574640000000, 55234, 289723, 9931); + (1575244800000, 46487, 284110, 9976); + (1575849600000, 64465, 307251, 9978); + (1576454400000, 53005, 289408, 9920); + (1577059200000, 42832, 281309, 9975); + (1577664000000, 56314, 294350, 9961); + (1578268800000, 51173, 289804, 9966); + (1578873600000, 68059, 309998, 10023); + (1579478400000, 64670, 308314, 10001); + (1580083200000, 71682, 314239, 10034); + (1580688000000, 77387, 320814, 9996); + (1581292800000, 100282, 346279, 9975); + (1581897600000, 86670, 329707, 9957); + (1582502400000, 76753, 311822, 9901); + (1583107200000, 83277, 304617, 9745); + (1583712000000, 80841, 304818, 9802); + (1584316800000, 94173, 322773, 9905); + (1584921600000, 71931, 300080, 9921); + (1585526400000, 69493, 299321, 9977); + (1586131200000, 89672, 321104, 9984); + (1586736000000, 74397, 308355, 10054); + (1587340800000, 100712, 336139, 10055); + (1587945600000, 93507, 327961, 10037); + (1588550400000, 112609, 346175, 10039); + (1589155200000, 91704, 324183, 10033); + (1589760000000, 102430, 335567, 10058); + (1590364800000, 94686, 324824, 10029); + (1590969600000, 91343, 322663, 10029); + (1591574400000, 125174, 357268, 10032); + (1592179200000, 95985, 329653, 10023); + (1592784000000, 122939, 357827, 10035); + (1593388800000, 95589, 327834, 10029); + (1593993600000, 128419, 362984, 10032); + (1594598400000, 122955, 359831, 10044); + (1595203200000, 121149, 354555, 10033); + (1595808000000, 123127, 356107, 10026); + (1596412800000, 139315, 372670, 10004); + (1597017600000, 157274, 393230, 10022); + (1597622400000, 135269, 366162, 9974); + (1598227200000, 148236, 374878, 9964); + (1598832000000, 127456, 352065, 9963); + (1599436800000, 151080, 373997, 9952); + (1600041600000, 126361, 350427, 9968); + (1600646400000, 140182, 365980, 10025); + (1601251200000, 138945, 362958, 9987); + (1601856000000, 125262, 348689, 10029); + (1602460800000, 163734, 386645, 10011); + (1603065600000, 130914, 354378, 9999); + (1603670400000, 165121, 389401, 10033); + (1604275200000, 138447, 361921, 10028); + (1604880000000, 189794, 404942, 9870); + (1605484800000, 146999, 362987, 9841); + (1606089600000, 164426, 389926, 9989); + (1606694400000, 168238, 392715, 10022); + (1607299200000, 140107, 361585, 10031); + (1607904000000, 189296, 412488, 10009); + (1608508800000, 152377, 376164, 10008); + (1609113600000, 198728, 420519, 9846); + (1609718400000, 185671, 406782, 9654); + (1610323200000, 179296, 398205, 9664); + (1610928000000, 218730, 439105, 9667); + (1611532800000, 172690, 392509, 9691); + (1612137600000, 187690, 410862, 9643); + (1612742400000, 264982, 494725, 9773); + (1613347200000, 232473, 465874, 9975); + (1613952000000, 273033, 504512, 9991); + (1614556800000, 240863, 470355, 9998); + (1615161600000, 302082, 533510, 10011); + (1615766400000, 258743, 487761, 10004); + (1616371200000, 344647, 569310, 9989); + (1616976000000, 445942, 674148, 10012); + (1617580800000, 547832, 775660, 9947); + (1618185600000, 656723, 887993, 10012); + (1618790400000, 811462, 1036103, 9922); + (1619395200000, 810847, 1040980, 9952); + (1620000000000, 273545, 359345, 3779); + ] diff --git a/vendors/irmin/bench/irmin-pack/trace_collection.ml b/vendors/irmin/bench/irmin-pack/trace_collection.ml new file mode 100644 index 0000000000000000000000000000000000000000..20b7b03209066ddd18d9df67cb06ed01cfd12e5e --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_collection.ml @@ -0,0 +1,258 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Trace file construction. + + This file is meant to be used from Tezos. OCaml version 4.09 and the 32bit + architecture should be supported. + + A module [Make_replayable] has yet to be implemented. *) + +open Lwt.Syntax + +(** Make state trace collector. *) +module Make_stat (Store : Irmin.Generic_key.KV) = struct + module Def = Trace_definitions.Stat_trace + + type t = { + writer : Def.writer; + store_path : string; + mutable t0 : Mtime_clock.counter; + mutable prev_merge_durations : float list; + mutable commit_before : Def.bag_of_stats * Def.store_before; + } + (** Imperative stat trace collector. It is optimised to minimise the CPU + footprint. *) + + module Bag_of_stats = struct + let pack () = + let module Pack_stats = Irmin_pack.Stats in + let module Unix_pack_stats = Irmin_pack_unix.Stats in + let pack_s = Pack_stats.get () in + let unix_s = Unix_pack_stats.get () in + let inode = Pack_stats.(Inode.export pack_s.inode) in + let pack_store = Unix_pack_stats.(Pack_store.export unix_s.pack_store) in + let finds = + Def. + { + total = pack_store.total; + from_staging = pack_store.from_staging; + from_lru = pack_store.from_lru; + from_pack_direct = pack_store.from_pack_direct; + from_pack_indexed = pack_store.from_pack_indexed; + } + in + Def. + { + finds; + appended_hashes = pack_store.appended_hashes; + appended_offsets = pack_store.appended_offsets; + inode_add = inode.inode_add; + inode_remove = inode.inode_remove; + inode_of_seq = inode.inode_of_seq; + inode_of_raw = inode.inode_of_raw; + inode_rec_add = inode.inode_rec_add; + inode_rec_remove = inode.inode_rec_remove; + inode_to_binv = inode.inode_to_binv; + inode_decode_bin = inode.inode_decode_bin; + inode_encode_bin = inode.inode_encode_bin; + } + + let tree () = + let open Store.Tree in + let v = counters () in + Def. + { + contents_hash = v.contents_hash; + contents_find = v.contents_find; + contents_add = v.contents_add; + node_hash = v.node_hash; + node_mem = v.node_mem; + node_add = v.node_add; + node_find = v.node_find; + node_val_v = v.node_val_v; + node_val_find = v.node_val_find; + node_val_list = v.node_val_list; + } + + let index prev_merge_durations = + let open Index.Stats in + let v = get () in + let new_merge_durations = + if v.merge_durations == prev_merge_durations then [] + else + (* This is anoying to compute. We can't rely on nb_merge. + Assume that all merge durations are unique. + Assume that we never have >10 merges at once. + *) + let rec aux acc = function + | [] -> acc + | hd :: tl -> + if List.mem hd prev_merge_durations then ( + assert (acc = []) (* No oldie after a newies *); + aux acc tl) + else aux ((hd /. 1e6) :: acc) tl + in + let l = aux [] v.merge_durations in + assert (l <> []) (* At least one newie *); + l + in + Def. + { + bytes_read = v.bytes_read; + nb_reads = v.nb_reads; + bytes_written = v.bytes_written; + nb_writes = v.nb_writes; + nb_merge = v.nb_merge; + new_merge_durations; + } + + let gc () = + let open Gc in + let v = quick_stat () in + Def. + { + minor_words = v.minor_words; + promoted_words = v.promoted_words; + major_words = v.major_words; + minor_collections = v.minor_collections; + major_collections = v.major_collections; + heap_words = v.heap_words; + compactions = v.compactions; + top_heap_words = v.top_heap_words; + stack_size = v.stack_size; + } + + let size_of_file path = + let open Unix.LargeFile in + try (stat path).st_size with Unix.Unix_error _ -> 0L + + let disk store_path = + let ( / ) left right = Filename.concat left right in + Def. + { + index_data = store_path / "index" / "data" |> size_of_file; + index_log = store_path / "index" / "log" |> size_of_file; + index_log_async = store_path / "index" / "log_async" |> size_of_file; + store_dict = store_path / "store.dict" |> size_of_file; + store_pack = store_path / "store.pack" |> size_of_file; + } + + let now () = + Mtime_clock.now () |> Mtime.to_uint64_ns |> Int64.to_float |> ( *. ) 1e-9 + + let create store_path prev_merge_durations = + Def. + { + pack = pack (); + tree = tree (); + index = index prev_merge_durations; + gc = gc (); + disk = disk store_path; + timestamp_wall = now (); + timestamp_cpu = Sys.time (); + } + end + + let create_file : string -> Def.config -> string -> t = + fun path config store_path -> + let header = + Def. + { + config; + hostname = Unix.gethostname (); + word_size = Sys.word_size; + timeofday = Unix.gettimeofday (); + initial_stats = + Bag_of_stats.create store_path + Index.Stats.((get ()).merge_durations); + } + in + let dummy_commit_before = + ( header.initial_stats, + Def.{ nodes = 0; leafs = 0; skips = 0; depth = 0; width = 0 } ) + in + { + writer = Def.create_file path header; + store_path; + t0 = Mtime_clock.counter (); + prev_merge_durations = Index.Stats.((get ()).merge_durations); + commit_before = dummy_commit_before; + } + + let flush { writer; _ } = Def.flush writer + let close { writer; _ } = Def.close writer + let remove { writer; _ } = Def.remove writer + let short_op_begin t = t.t0 <- Mtime_clock.counter () + + let short_op_end { t0; writer; _ } short_op = + let duration = + Mtime_clock.count t0 |> Mtime.Span.to_s |> Int32.bits_of_float + in + let op = + match short_op with + | `Add -> `Add duration + | `Remove -> `Remove duration + | `Find -> `Find duration + | `Mem -> `Mem duration + | `Mem_tree -> `Mem_tree duration + | `Checkout -> `Checkout duration + | `Copy -> `Copy duration + in + Def.append_row writer op + + let create_store_before tree = + let+ Store.Tree.{ nodes; leafs; skips; depth; width } = + Store.Tree.stats ~force:false tree + in + Def.{ nodes; leafs; skips; depth; width } + + let create_store_after tree = + let* watched_nodes_length = + Lwt_list.map_s + (fun (_, steps) -> Store.Tree.length tree steps) + Def.step_list_per_watched_node + in + Lwt.return Def.{ watched_nodes_length } + + let commit_begin t tree = + short_op_begin t; + let stats_before = + Bag_of_stats.create t.store_path t.prev_merge_durations + in + t.prev_merge_durations <- Index.Stats.((get ()).merge_durations); + let+ store_before = create_store_before tree in + t.commit_before <- (stats_before, store_before) + + let commit_end t tree = + let duration = Mtime_clock.count t.t0 |> Mtime.Span.to_s in + let duration = duration |> Int32.bits_of_float in + let stats_after = Bag_of_stats.create t.store_path t.prev_merge_durations in + t.prev_merge_durations <- Index.Stats.((get ()).merge_durations); + let+ store_after = create_store_after tree in + let op = + `Commit + Def. + { + duration; + before = fst t.commit_before; + after = stats_after; + store_before = snd t.commit_before; + store_after; + } + in + Def.append_row t.writer op +end diff --git a/vendors/irmin/bench/irmin-pack/trace_common.ml b/vendors/irmin/bench/irmin-pack/trace_common.ml new file mode 100644 index 0000000000000000000000000000000000000000..ce2773d0cd506b9442a1172d89c9b8c6f9a5db13 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_common.ml @@ -0,0 +1,285 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [Trace_common] contains utility to simplify the management of files using + the following layout: + + {v + - Magic (Magic.t, 8 bytes) + - Version (int32, 4 bytes) + - Length of header (varint, >=1 byte) + - Header (header_t, _ bytes) + - Arbitrary long series of rows, of unspecified length, each prefixed by their length: + - Length of row (varint, >=1 byte) + - Row (row_t, _ bytes) + v} + + This file is meant to be used from Tezos. OCaml version 4.09 and the 32bit + architecture should be supported. + + {3 Example} + + {[ + module Example = struct + module V2 = struct + let version = 2 + + type header = unit [@@deriving repr] + type row = [ `A | `B | `C ] [@@deriving repr] + end + + module V1 = struct + let version = 1 + + type header = unit [@@deriving repr] + type row = [ `A | `B ] [@@deriving repr] + + let to_v2 x = (x :> V2.row) + end + + module V0 = struct + let version = 0 + + type header = unit [@@deriving repr] + type row = [ `A of int | `B of int ] [@@deriving repr] + + let to_v1 = function `A _ -> `A | `B _ -> `B + end + + module Latest = V2 + include Latest + + include Trace_common.Io (struct + module Latest = Latest + + let magic = Trace_common.Magic.of_string "Magique_" + + let get_version_converter = function + | 2 -> + Trace_common.Version_converter + { + header_t = V2.header_t; + row_t = V2.row_t; + upgrade_header = Fun.id; + upgrade_row = Fun.id; + } + | 1 -> + Version_converter + { + header_t = V1.header_t; + row_t = V1.row_t; + upgrade_header = Fun.id; + upgrade_row = V1.to_v2; + } + | 0 -> + Version_converter + { + header_t = V0.header_t; + row_t = V0.row_t; + upgrade_header = Fun.id; + upgrade_row = (fun x -> V0.to_v1 x |> V1.to_v2); + } + | i -> Fmt.invalid_arg "Unknown Example version %d" i + end) + end + ]} *) + +module Seq = struct + include Seq + + (* Backported from ocaml 4.11 *) + let rec unfold f u () = + match f u with None -> Nil | Some (x, u') -> Cons (x, unfold f u') +end + +module Magic : sig + type t + + val of_string : string -> t + val to_string : t -> string + val pp : Format.formatter -> t -> unit +end = struct + type t = string + + let of_string s = + if String.length s <> 8 then + invalid_arg "Magic.of_string, string should have 8 chars"; + s + + let to_string s = s + let pp ppf s = Format.fprintf ppf "%s" (String.escaped s) +end + +type ('latest_header, 'latest_row, 'header, 'row) version_converter' = { + header_t : 'header Repr.ty; + row_t : 'row Repr.ty; + upgrade_header : 'header -> 'latest_header; + upgrade_row : 'row -> 'latest_row; +} +(** Contains everything needed to read a file as if it is written with the + lastest version. *) + +(** A box containing the above record *) +type ('latest_header, 'latest_row) version_converter = + | Version_converter : + ('latest_header, 'latest_row, 'header, 'row) version_converter' + -> ('latest_header, 'latest_row) version_converter + +module type File_format = sig + (** The latest up-to-date definition of the file format *) + module Latest : sig + val version : int + + type header [@@deriving repr] + type row [@@deriving repr] + end + + val magic : Magic.t + + val get_version_converter : + int -> (Latest.header, Latest.row) version_converter +end + +(** Very similar to what can be found in "repr/type_binary.ml", but working + straight off channels. + + [Var_int.read_exn] reads the chars one by one from the provided [chan]. The + recursion stops as soon as a read char has its 8th bit equal to [0]. + + [Var_int.write] could be implemented using [Repr.encode_bin int], but since + [read_exn] isn't implemented using repr, [write] isn't either. *) +module Var_int = struct + let chars = + Array.init 256 (fun i -> Bytes.unsafe_to_string (Bytes.make 1 (Char.chr i))) + + let write : int -> out_channel -> unit = + let int i k = + let rec aux n k = + if n >= 0 && n < 128 then k chars.(n) + else + let out = 128 lor (n land 127) in + k chars.(out); + aux (n lsr 7) k + in + aux i k + in + fun i chan -> int i (output_string chan) + + let read_exn : in_channel -> int = + fun chan -> + let max_bits = Sys.word_size - 1 in + let rec aux n p = + if p >= max_bits then failwith "Failed to decode varint"; + let i = input_char chan |> Char.code in + let n = n + ((i land 127) lsl p) in + if i >= 0 && i < 128 then n else aux n (p + 7) + in + aux 0 0 +end + +(** Derive the IO operations from a file format. Only the write operations are + performance sensitive, the read operations are not. *) +module Io (Ff : File_format) = struct + let decode_i32 = Repr.(decode_bin int32 |> unstage) + let encode_i32 = Repr.(encode_bin int32 |> unstage) + let encode_lheader = Repr.(encode_bin Ff.Latest.header_t |> unstage) + let encode_lrow = Repr.(encode_bin Ff.Latest.row_t |> unstage) + let magic = Ff.magic + + let read_with_prefix_exn : (string -> int ref -> 'a) -> in_channel -> 'a = + fun decode chan -> + (* First read the prefix *) + let len = Var_int.read_exn chan in + (* Then read the repr. *) + let pos_ref = ref 0 in + let v = + (* This could fail if [len] is not long enough for repr (corruption) *) + decode (really_input_string chan len) pos_ref + in + if len <> !pos_ref then + Fmt.failwith + "An value read in the Trace was expected to take %d bytes, but it took \ + only %d." + len !pos_ref; + v + + let decoded_seq_of_encoded_chan_with_prefixes : + 'a Repr.ty -> in_channel -> 'a Seq.t = + fun repr chan -> + let decode = Repr.decode_bin repr |> Repr.unstage in + let produce_row () = + try + let row = read_with_prefix_exn decode chan in + Some (row, ()) + with End_of_file -> None + in + Seq.unfold produce_row () + + let open_reader : string -> Ff.Latest.header * Ff.Latest.row Seq.t = + fun path -> + let chan = open_in_bin path in + let len = LargeFile.in_channel_length chan in + if len < 12L then + Fmt.invalid_arg "File '%s' should be at least 12 byte long." path; + + let magic = Magic.of_string (really_input_string chan 8) in + if magic <> Ff.magic then + Fmt.invalid_arg "File '%s' has magic '%a'. Expected '%a'." path Magic.pp + magic Magic.pp Ff.magic; + + let (Version_converter vc) = + let pos_ref = ref 0 in + let version = decode_i32 (really_input_string chan 4) pos_ref in + assert (!pos_ref = 4); + Ff.get_version_converter (Int32.to_int version) + in + + let header = + let decode_header = Repr.(decode_bin vc.header_t |> unstage) in + read_with_prefix_exn decode_header chan |> vc.upgrade_header + in + let seq = + decoded_seq_of_encoded_chan_with_prefixes vc.row_t chan + |> Seq.map vc.upgrade_row + in + (header, seq) + + type writer = { path : string; channel : out_channel; buffer : Buffer.t } + + let create_file path header = + let channel = open_out path in + let buffer = Buffer.create 0 in + output_string channel (Magic.to_string Ff.magic); + encode_i32 (Int32.of_int Ff.Latest.version) (output_string channel); + encode_lheader header (Buffer.add_string buffer); + Var_int.write (Buffer.length buffer) channel; + output_string channel (Buffer.contents buffer); + Buffer.clear buffer; + { path; channel; buffer } + + let append_row { channel; buffer; _ } row = + encode_lrow row (Buffer.add_string buffer); + Var_int.write (Buffer.length buffer) channel; + output_string channel (Buffer.contents buffer); + Buffer.clear buffer + + let flush { channel; _ } = flush channel + let close { channel; _ } = close_out channel + + let remove { channel; path; _ } = + close_out channel; + Sys.remove path +end diff --git a/vendors/irmin/bench/irmin-pack/trace_definitions.ml b/vendors/irmin/bench/irmin-pack/trace_definitions.ml new file mode 100644 index 0000000000000000000000000000000000000000..bfaecf2d66be32781244eeb04306507273545cb3 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_definitions.ml @@ -0,0 +1,505 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Traces file format definitions. + + This file is meant to be used from Tezos. OCaml version 4.09 and the 32bit + architecture should be supported. + + {3 Traces Workflow} + + A Tezos node (may) output a [Raw_replayable_trace] file. Such a trace should + be postprocessed to create a [Replayable_trace]. + + A Tezos node (may) output a [Stat_trace] file. + + {e trace_stats.exe summarise} takes a [Stat_trace] file and summarises it to + a {e stat_summary.json} file. + + A series of python script take a {e stat_summary.json} file and produce + plots (e.g. png files). + + {e tree.exe} takes a [Replayable_trace] file, internally produces a + [Stat_trace] file and yields it to [Trace_stat_summary] to produce a + {e stat_summary.json} file. *) + +(** [Replayable_trace], a trace of Tezos's interactions with Irmin. + + {3 Interleaved Contexts and Commits} + + All the recorded operations in Tezos operate on (and create new) immutable + records of type [context]. Most of the time, everything is linear (i.e. the + input context to an operation is the latest output context), but there + sometimes are several parallel chains of contexts, where all but one will + end up being discarded. + + Similarly to contexts, commits are not always linear, i.e. a checkout may + choose a parent that is not the latest commit. + + To solve this conundrum when replaying the trace, we need to remember all + the [context_id -> tree] and [trace commit hash -> real commit hash] pairs + to make sure an operation is operating on the right parent. + + In the trace, the context indices and the commit hashes are 'scoped', + meaning that they are tagged with a boolean information indicating if this + is the very last occurence of that value in the trace. This way we can + discard a recorded pair as soon as possible. + + In practice, there is only 1 context and 1 commit in history, and sometimes + 0 or 2, but the code is ready for more. *) +module Replayable_trace = struct + module V0 = struct + let version = 0 + + type header = unit [@@deriving repr] + type 'a scope = Forget of 'a | Keep of 'a [@@deriving repr] + type key = string list [@@deriving repr] + type hash = string [@@deriving repr] + type message = string [@@deriving repr] + type context_id = int64 [@@deriving repr] + + type add = { + key : key; + value : string; + in_ctx_id : context_id scope; + out_ctx_id : context_id scope; + } + [@@deriving repr] + + type copy = { + key_src : key; + key_dst : key; + in_ctx_id : context_id scope; + out_ctx_id : context_id scope; + } + [@@deriving repr] + + type commit = { + hash : hash scope; + date : int64; + message : message; + parents : hash scope list; + in_ctx_id : context_id scope; + } + [@@deriving repr] + + type row = + (* Operation(s) that create a context from none *) + | Checkout of hash scope * context_id scope + (* Operations that create a context from one *) + | Add of add + | Remove of key * context_id scope * context_id scope + | Copy of copy + (* Operations that just read a context *) + | Find of key * bool * context_id scope + | Mem of key * bool * context_id scope + | Mem_tree of key * bool * context_id scope + | Commit of commit + [@@deriving repr] + end + + module Latest = V0 + include Latest + + include Trace_common.Io (struct + module Latest = Latest + + (** Irmin's Replayable Bootstrap Trace *) + let magic = Trace_common.Magic.of_string "IrmRepBT" + + let get_version_converter = function + | 0 -> + Trace_common.Version_converter + { + header_t = V0.header_t; + row_t = V0.row_t; + upgrade_header = Fun.id; + upgrade_row = Fun.id; + } + | i -> Fmt.invalid_arg "Unknown Replayable_trace version %d" i + end) +end + +(** Trace of a tezos node run, or a replay run. + + May be summarised to a JSON file. + + {3 Implicitly Auto-Upgradable File Format} + + The stat trace has these two properties: + + - It supports extensions, in order to change or add new stats in the future. + - Old trace files from old versions are still readable. + + There are multiple reasons for wanting compatibility with old versions: + + - Because one of the goal of the benchmarks is to assess the evolution of + performances across distant versions of irmin, we need stability in order + to avoid recomputing everything every time. + - When those traces will be produced by Tezos nodes, we have no control over + the version of those traces. + + For this system to work, the "decoding shape" of a version of the stat trace + shouldn't ever change (once fixed). The way the trace is built for a version + should be stable too. + + To modify something in the definition or the collection: append a new + version. *) +module Stat_trace = struct + module V0 = struct + let version = 0 + + type float32 = int32 [@@deriving repr] + + type pack = { + finds : int; + cache_misses : int; + appended_hashes : int; + appended_offsets : int; + } + [@@deriving repr] + (** Stats extracted from [Irmin_pack.Stats.get ()]. *) + + type tree = { + contents_hash : int; + contents_find : int; + contents_add : int; + node_hash : int; + node_mem : int; + node_add : int; + node_find : int; + node_val_v : int; + node_val_find : int; + node_val_list : int; + } + [@@deriving repr] + (** Stats extracted from [Irmin.Tree.counters ()]. *) + + type index = { + bytes_read : int; + nb_reads : int; + bytes_written : int; + nb_writes : int; + nb_merge : int; + new_merge_durations : float list; + } + [@@deriving repr] + (** Stats extracted from [Index.Stats.get ()]. + + [new_merge_durations] is not just a mirror of + [Index.Stats.merge_durations], it only contains the new entries since + the last time it was recorded. This list is always empty when in the + header. *) + + type gc = { + minor_words : float; + promoted_words : float; + major_words : float; + minor_collections : int; + major_collections : int; + heap_words : int; + compactions : int; + top_heap_words : int; + stack_size : int; + } + [@@deriving repr] + (** Stats extracted from [Gc.quick_stat ()]. *) + + type disk = { + index_data : int64; + index_log : int64; + index_log_async : int64; + store_dict : int64; + store_pack : int64; + } + [@@deriving repr] + (** Stats extracted from filesystem. Requires the path to the irmin store. *) + + type 'pack_stats bag_of_stats_base = { + pack : 'pack_stats; + tree : tree; + index : index; + gc : gc; + disk : disk; + timestamp_wall : float; + timestamp_cpu : float; + } + [@@deriving repr] + (** Melting pot of stats, recorded before and after every commits. + + They are necessary in order to compute any throughput analytics. *) + + type store_before = { + nodes : int; + leafs : int; + skips : int; + depth : int; + width : int; + } + [@@deriving repr] + (** Stats computed from the [tree] value passed to the commit operation, + before the commit, when the tree still carries the modifications brought + by the previous operations. *) + + type watched_node = + [ `Contracts_index + | `Big_maps_index + | `Rolls_index + | `Rolls_owner_current + | `Commitments + | `Contracts_index_ed25519 + | `Contracts_index_originated ] + [@@deriving repr, enum] + + type store_after = { watched_nodes_length : int list } [@@deriving repr] + (** Stats computed on the [tree] value passed to the commit operation, after + the commit, when the inode has been reconstructed and that [Tree.length] + is now innexpensive to perform. *) + + type 'pack_stats commit_base = { + duration : float32; + before : 'pack_stats bag_of_stats_base; + after : 'pack_stats bag_of_stats_base; + store_before : store_before; + store_after : store_after; + } + [@@deriving repr] + + type 'pack_stats row_base = + [ `Add of float32 + | `Remove of float32 + | `Find of float32 + | `Mem of float32 + | `Mem_tree of float32 + | `Checkout of float32 + | `Copy of float32 + | `Commit of 'pack_stats commit_base ] + [@@deriving repr] + + type row = pack row_base [@@deriving repr] + (** Stats gathered while running an operation. + + {3 Operation durations} + + For each operation we record its wall time length using a [float32], a + [float16] would be suitable too (it has >3 digits of precision). + + {3 Time and disk performance considerations} + + On commit we record a lot of things, thankfuly the frequency is low: + ~1/600. 599 small operations weigh ~3600 bytes, 1 commit weighs ~300 + bytes. The trace reaches 1GB after ~250k commits. *) + + type setup_play = unit [@@deriving repr] + (** Informations gathered from the tezos node. + + Noting so far. Any ideas? *) + + type setup_replay = { + path_conversion : [ `None | `V1 | `V0_and_v1 | `V0 ]; + artefacts_dir : string; + } + [@@deriving repr] + (** Informations gathered from the tree.exe parameters. *) + + type config = { + inode_config : int * int * int; + store_type : [ `Pack | `Pack_layered | `Pack_mem ]; + setup : [ `Play of setup_play | `Replay of setup_replay ]; + } + [@@deriving repr] + + type 'pack_stats header_base = { + config : config; + hostname : string; + timeofday : float; + word_size : int; + initial_stats : 'pack_stats bag_of_stats_base; + } + [@@deriving repr] + + type header = pack header_base [@@deriving repr] + (** File header. + + {3 Timestamps} + + [stats.timestamp_wall] and [stats.timestamp_cpu] are the starting points + of the trace, they are to be substracted from their counterpart in + [commit] to compute time spans. + + [timeofday] is the date and time at which the stats started to be + accumulated. + + [stats.timestamp_wall] may originate from [Mtime_clock.now]. + + [stats.timestamp_cpu] may originate from [Sys.time]. + + It would be great to be able to record the library/sources versions. *) + + type commit = pack commit_base [@@deriving repr] + type bag_of_stats = pack bag_of_stats_base [@@deriving repr] + end + + module V1 = struct + include V0 + + let version = 1 + + type finds = { + total : int; + from_staging : int; + from_lru : int; + from_pack_direct : int; + from_pack_indexed : int; + } + [@@deriving repr] + (** Stats extracted from [Irmin_pack.Stats.get ()]. *) + + type pack = { + finds : finds; + appended_hashes : int; + appended_offsets : int; + inode_add : int; + inode_remove : int; + inode_of_seq : int; + inode_of_raw : int; + inode_rec_add : int; + inode_rec_remove : int; + inode_to_binv : int; + inode_decode_bin : int; + inode_encode_bin : int; + } + [@@deriving repr] + (** Stats extracted from [Irmin_pack.Stats.get ()]. *) + + type commit = pack commit_base [@@deriving repr] + type bag_of_stats = pack bag_of_stats_base [@@deriving repr] + type row = pack row_base [@@deriving repr] + type header = pack header_base [@@deriving repr] + + (* [v0.cache_misses] is lost *) + let v1pack_of_v0pack (v0 : V0.pack) : pack = + { + finds = + { + total = v0.finds; + from_staging = 0; + from_lru = 0; + from_pack_direct = 0; + from_pack_indexed = 0; + }; + appended_hashes = v0.appended_hashes; + appended_offsets = v0.appended_offsets; + inode_add = 0; + inode_remove = 0; + inode_of_seq = 0; + inode_of_raw = 0; + inode_rec_add = 0; + inode_rec_remove = 0; + inode_to_binv = 0; + inode_decode_bin = 0; + inode_encode_bin = 0; + } + + let v1bos_of_v0bos (v0 : V0.bag_of_stats) : bag_of_stats = + { + pack = v1pack_of_v0pack v0.pack; + tree = v0.tree; + index = v0.index; + gc = v0.gc; + disk = v0.disk; + timestamp_wall = v0.timestamp_wall; + timestamp_cpu = v0.timestamp_cpu; + } + + let v1commit_of_v0commit (v0 : V0.commit) : commit = + { + duration = v0.duration; + before = v1bos_of_v0bos v0.before; + after = v1bos_of_v0bos v0.after; + store_before = v0.store_before; + store_after = v0.store_after; + } + + let v1row_of_v0row (v0 : V0.row) : row = + match v0 with + | `Commit payload -> `Commit (v1commit_of_v0commit payload) + | ( `Add _ | `Remove _ | `Find _ | `Mem _ | `Mem_tree _ | `Checkout _ + | `Copy _ ) as v0 -> + v0 + + let v1header_of_v0header (v0 : V0.header) : header = + { + config = v0.config; + hostname = v0.hostname; + timeofday = v0.timeofday; + word_size = v0.word_size; + initial_stats = v1bos_of_v0bos v0.initial_stats; + } + end + + module Latest = V1 + include Latest + + let watched_nodes : watched_node list = + List.init (max_watched_node + 1) (fun i -> + watched_node_of_enum i |> Option.get) + + let step_list_per_watched_node = + let aux = function + | `Contracts_index -> [ "data"; "contracts"; "index" ] + | `Big_maps_index -> [ "data"; "big_maps"; "index" ] + | `Rolls_index -> [ "data"; "rolls"; "index" ] + | `Rolls_owner_current -> [ "data"; "rolls"; "owner"; "current" ] + | `Commitments -> [ "data"; "commitments" ] + | `Lol -> [] + | `Contracts_index_ed25519 -> [ "data"; "contracts"; "index"; "ed25519" ] + | `Contracts_index_originated -> + [ "data"; "contracts"; "index"; "originated" ] + in + List.combine watched_nodes (List.map aux watched_nodes) + + let path_per_watched_node = + List.map + (fun (k, l) -> (k, "/" ^ String.concat "/" l)) + step_list_per_watched_node + + include Trace_common.Io (struct + module Latest = Latest + + (** Irmin's Stats Bootstrap Trace *) + let magic = Trace_common.Magic.of_string "IrmStaBT" + + let get_version_converter = function + | 0 -> + Trace_common.Version_converter + { + header_t = V0.header_t; + row_t = V0.row_t; + upgrade_header = v1header_of_v0header; + upgrade_row = v1row_of_v0row; + } + | 1 -> + Trace_common.Version_converter + { + header_t = V1.header_t; + row_t = V1.row_t; + upgrade_header = Fun.id; + upgrade_row = Fun.id; + } + | i -> Fmt.invalid_arg "Unknown Stat_trace version %d" i + end) +end diff --git a/vendors/irmin/bench/irmin-pack/trace_replay.ml b/vendors/irmin/bench/irmin-pack/trace_replay.ml new file mode 100644 index 0000000000000000000000000000000000000000..da51ff30e9c3368f4785a8e8e97308642f92b3e5 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_replay.ml @@ -0,0 +1,494 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Export_for_backends +open Bench_common +include Trace_replay_intf +module Def = Trace_definitions.Replayable_trace +module Seq = Trace_common.Seq + +let is_hex_char = function + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + +let is_2char_hex s = + if String.length s <> 2 then false + else s |> String.to_seq |> List.of_seq |> List.for_all is_hex_char + +let all_6_2char_hex a b c d e f = + is_2char_hex a + && is_2char_hex b + && is_2char_hex c + && is_2char_hex d + && is_2char_hex e + && is_2char_hex f + +let is_30char_hex s = + if String.length s <> 30 then false + else s |> String.to_seq |> List.of_seq |> List.for_all is_hex_char + +(** This function flattens all the 6 step-long chunks forming 40 byte-long + hashes to a single step. + + Those flattenings are performed during the trace replay, i.e. they count in + the total time. + + If a path contains 2 or more of those patterns, only the leftmost one is + converted. + + A chopped hash has this form + + {v ([0-9a-f]{2}/){5}[0-9a-f]{30} v} + + and is flattened to that form + + {v [0-9a-f]{40} v} *) +let flatten_v0 key = + let rec aux rev_prefix suffix = + match suffix with + | a :: b :: c :: d :: e :: f :: tl + when is_2char_hex a + && is_2char_hex b + && is_2char_hex c + && is_2char_hex d + && is_2char_hex e + && is_30char_hex f -> + let mid = a ^ b ^ c ^ d ^ e ^ f in + aux (mid :: rev_prefix) tl + | hd :: tl -> aux (hd :: rev_prefix) tl + | [] -> List.rev rev_prefix + in + aux [] key + +(** This function removes from the paths all the 6 step-long hashes of this form + + {v ([0-9a-f]{2}/){6} v} + + Those flattenings are performed during the trace replay, i.e. they count in + the total time. + + The paths in tezos: + https://www.dailambda.jp/blog/2020-05-11-plebeia/#tezos-path + + Tezos' PR introducing this flattening: + https://gitlab.com/tezos/tezos/-/merge_requests/2771 *) +let flatten_v1 = function + | "data" :: "contracts" :: "index" :: a :: b :: c :: d :: e :: f :: tl + when all_6_2char_hex a b c d e f -> ( + match tl with + | hd :: "delegated" :: a :: b :: c :: d :: e :: f :: tl + when all_6_2char_hex a b c d e f -> + "data" :: "contracts" :: "index" :: hd :: "delegated" :: tl + | _ -> "data" :: "contracts" :: "index" :: tl) + | "data" :: "big_maps" :: "index" :: a :: b :: c :: d :: e :: f :: tl + when all_6_2char_hex a b c d e f -> + "data" :: "big_maps" :: "index" :: tl + | "data" :: "rolls" :: "index" :: _ :: _ :: tl -> + "data" :: "rolls" :: "index" :: tl + | "data" :: "rolls" :: "owner" :: "current" :: _ :: _ :: tl -> + "data" :: "rolls" :: "owner" :: "current" :: tl + | "data" :: "rolls" :: "owner" :: "snapshot" :: a :: b :: _ :: _ :: tl -> + "data" :: "rolls" :: "owner" :: "snapshot" :: a :: b :: tl + | l -> l + +let flatten_op ~flatten_path = function + | Def.Checkout _ as op -> op + | Add op -> Add { op with key = flatten_path op.key } + | Remove (keys, in_ctx_id, out_ctx_id) -> + Remove (flatten_path keys, in_ctx_id, out_ctx_id) + | Copy op -> + Copy + { + op with + key_src = flatten_path op.key_src; + key_dst = flatten_path op.key_dst; + } + | Find (keys, b, ctx) -> Find (flatten_path keys, b, ctx) + | Mem (keys, b, ctx) -> Mem (flatten_path keys, b, ctx) + | Mem_tree (keys, b, ctx) -> Mem_tree (flatten_path keys, b, ctx) + | Commit _ as op -> op + +let open_commit_sequence max_ncommits path_conversion path : Def.row list Seq.t + = + let flatten_path = + match path_conversion with + | `None -> Fun.id + | `V1 -> flatten_v1 + | `V0 -> flatten_v0 + | `V0_and_v1 -> fun p -> flatten_v1 p |> flatten_v0 + in + + let rec aux (ops_seq, commits_sent, ops) = + if commits_sent >= max_ncommits then None + else + match ops_seq () with + | Seq.Nil -> None + | Cons ((Def.Commit _ as op), ops_seq) -> + let ops = op :: ops |> List.rev in + Some (ops, (ops_seq, commits_sent + 1, [])) + | Cons (op, ops_seq) -> + let op = flatten_op ~flatten_path op in + aux (ops_seq, commits_sent, op :: ops) + in + let _header, ops_seq = Def.open_reader path in + Seq.unfold aux (ops_seq, 0, []) + +module Make (Store : Store) = struct + include Config + module Stat_collector = Trace_collection.Make_stat (Store) + + type key = Store.contents_key [@@deriving irmin ~pp] + type context = { tree : Store.tree } + + type t = { + contexts : (int64, context) Hashtbl.t; + hash_corresps : (Def.hash, Store.commit_key) Hashtbl.t; + mutable commits_since_start_or_gc : int; + key_per_commit_idx : (int, Store.commit_key) Hashtbl.t; + } + + let error_find op k b n_op n_c in_ctx_id = + Fmt.failwith + "Cannot reproduce operation %d on ctx %Ld of commit %d %s @[k = %a@] \ + expected %b" + n_op in_ctx_id n_c op + Fmt.(list ~sep:comma string) + k b + + let unscope = function Def.Forget v -> v | Keep v -> v + + let maybe_forget_hash t = function + | Def.Forget h -> Hashtbl.remove t.hash_corresps h + | Keep _ -> () + + let maybe_forget_ctx t = function + | Def.Forget ctx -> Hashtbl.remove t.contexts ctx + | Keep _ -> () + + let exec_checkout t stats repo h_trace out_ctx_id = + let h_store = Hashtbl.find t.hash_corresps (unscope h_trace) in + maybe_forget_hash t h_trace; + Stat_collector.short_op_begin stats; + Store.Commit.of_key repo h_store >|= function + | None -> failwith "prev commit not found" + | Some commit -> + let tree = Store.Commit.tree commit in + Stat_collector.short_op_end stats `Checkout; + Hashtbl.add t.contexts (unscope out_ctx_id) { tree }; + maybe_forget_ctx t out_ctx_id + + let exec_add t stats key v in_ctx_id out_ctx_id empty_blobs = + let v = if empty_blobs then Bytes.empty else Bytes.of_string v in + let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in + maybe_forget_ctx t in_ctx_id; + Stat_collector.short_op_begin stats; + let+ tree = Store.Tree.add tree key v in + Stat_collector.short_op_end stats `Add; + Hashtbl.add t.contexts (unscope out_ctx_id) { tree }; + maybe_forget_ctx t out_ctx_id + + let exec_remove t stats keys in_ctx_id out_ctx_id = + let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in + maybe_forget_ctx t in_ctx_id; + Stat_collector.short_op_begin stats; + let+ tree = Store.Tree.remove tree keys in + Stat_collector.short_op_end stats `Remove; + Hashtbl.add t.contexts (unscope out_ctx_id) { tree }; + maybe_forget_ctx t out_ctx_id + + let exec_copy t stats from to_ in_ctx_id out_ctx_id = + let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in + maybe_forget_ctx t in_ctx_id; + Stat_collector.short_op_begin stats; + Store.Tree.find_tree tree from >>= function + | None -> failwith "Couldn't find tree in exec_copy" + | Some sub_tree -> + let* tree = Store.Tree.add_tree tree to_ sub_tree in + Stat_collector.short_op_end stats `Copy; + Hashtbl.add t.contexts (unscope out_ctx_id) { tree }; + maybe_forget_ctx t out_ctx_id; + Lwt.return_unit + + let exec_find t stats n i keys b in_ctx_id = + let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in + maybe_forget_ctx t in_ctx_id; + Stat_collector.short_op_begin stats; + let+ query = Store.Tree.find tree keys in + Stat_collector.short_op_end stats `Find; + if Option.is_some query <> b then + error_find "find" keys b i n (unscope in_ctx_id) + + let exec_mem t stats n i keys b in_ctx_id = + let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in + maybe_forget_ctx t in_ctx_id; + Stat_collector.short_op_begin stats; + let+ b' = Store.Tree.mem tree keys in + Stat_collector.short_op_end stats `Mem; + if b <> b' then error_find "mem" keys b i n (unscope in_ctx_id) + + let exec_mem_tree t stats n i keys b in_ctx_id = + let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in + maybe_forget_ctx t in_ctx_id; + Stat_collector.short_op_begin stats; + let+ b' = Store.Tree.mem_tree tree keys in + Stat_collector.short_op_end stats `Mem_tree; + if b <> b' then error_find "mem_tree" keys b i n (unscope in_ctx_id) + + let check_hash_trace h_trace h_store = + let h_store = Irmin.Type.(to_string Store.Hash.t) h_store in + if h_trace <> h_store then + Fmt.failwith "hash replay %s, hash trace %s" h_store h_trace + + let exec_commit t stats repo h_trace date message parents_trace in_ctx_id + check_hash = + let parents_store = + parents_trace + |> List.map unscope + |> List.map (Hashtbl.find t.hash_corresps) + in + List.iter (maybe_forget_hash t) parents_trace; + let { tree } = Hashtbl.find t.contexts (unscope in_ctx_id) in + maybe_forget_ctx t in_ctx_id; + let* () = Stat_collector.commit_begin stats tree in + let* _ = + (* in tezos commits call Tree.list first for the unshallow operation *) + Store.Tree.list tree [] + in + let info = Store.Info.v ~author:"Tezos" ~message date in + let* commit = Store.Commit.v repo ~info ~parents:parents_store tree in + let+ () = Stat_collector.commit_end stats tree in + Store.Tree.clear tree; + let k_store, h_store = Store.Commit.(key commit, hash commit) in + if check_hash then check_hash_trace (unscope h_trace) h_store; + (* It's okey to have [h_trace] already in history. It corresponds to + * re-commiting the same thing, hence the [.replace] below. *) + Hashtbl.replace t.hash_corresps (unscope h_trace) k_store; + maybe_forget_hash t h_trace; + let () = + let tbl = t.key_per_commit_idx in + Hashtbl.add tbl (Hashtbl.length tbl) k_store + in + () + + let add_operations t repo operations n stats check_hash empty_blobs = + let rec aux l i = + match l with + | Def.Checkout (h, out_ctx_id) :: tl -> + let* () = exec_checkout t stats repo h out_ctx_id in + aux tl (i + 1) + | Add op :: tl -> + let* () = + exec_add t stats op.key op.value op.in_ctx_id op.out_ctx_id + empty_blobs + in + aux tl (i + 1) + | Remove (keys, in_ctx_id, out_ctx_id) :: tl -> + let* () = exec_remove t stats keys in_ctx_id out_ctx_id in + aux tl (i + 1) + | Copy op :: tl -> + let* () = + exec_copy t stats op.key_src op.key_dst op.in_ctx_id op.out_ctx_id + in + aux tl (i + 1) + | Find (keys, b, in_ctx_id) :: tl -> + let* () = exec_find t stats n i keys b in_ctx_id in + aux tl (i + 1) + | Mem (keys, b, in_ctx_id) :: tl -> + let* () = exec_mem t stats n i keys b in_ctx_id in + aux tl (i + 1) + | Mem_tree (keys, b, in_ctx_id) :: tl -> + let* () = exec_mem_tree t stats n i keys b in_ctx_id in + aux tl (i + 1) + | [ Commit op ] -> + exec_commit t stats repo op.hash op.date op.message op.parents + op.in_ctx_id check_hash + | Commit _ :: _ | [] -> + failwith "A batch of operation should end with a commit" + in + aux operations 0 + + let gc_actions config i commits_since_start_or_gc = + let gc_enabled = + (* Is GC enabled at all? *) + config.gc_every > 0 + in + let gc_wait_enabled = + (* Will GC wait be called at all? *) + gc_enabled && config.gc_wait_after > 0 + in + + let first_gc_occured = i <> commits_since_start_or_gc in + + let time_to_start = + (* Is it time to start GC? *) + if first_gc_occured then commits_since_start_or_gc = config.gc_every + else + let gc_commit_idx = + (* [i] is the replay step and also the commit index of the next + commit and also the number of commits replayed so far. + + [i - t.gc_distance_in_the_past - 1] is the index of the commit we + want to GC. *) + i - config.gc_distance_in_the_past - 1 + in + gc_commit_idx = 1 + in + let time_to_wait = + (* Is it time to wait GC? *) + if first_gc_occured then commits_since_start_or_gc = config.gc_wait_after + else false + in + + let really_start_gc = gc_enabled && time_to_start in + let really_wait_gc = gc_wait_enabled && time_to_wait in + (really_wait_gc, really_start_gc) + + let add_commits config repo commit_seq on_commit on_end stats check_hash + empty_blobs = + let max_ncommits = config.number_of_commits_to_replay in + with_progress_bar ~message:"Replaying trace" ~n:max_ncommits ~unit:"commit" + @@ fun prog -> + let t = + { + contexts = Hashtbl.create 3; + hash_corresps = Hashtbl.create 3; + commits_since_start_or_gc = 0; + key_per_commit_idx = Hashtbl.create 3; + } + in + + (* Manually add genesis context *) + Hashtbl.add t.contexts 0L { tree = Store.Tree.empty () }; + + let finalise_gc_and_log ~wait i repo = + let counter = Mtime_clock.counter () in + let* wait = Store.finalise_gc ~wait repo in + let dt = Mtime_clock.count counter in + (if wait then + let gc_commit_key = Hashtbl.find t.key_per_commit_idx (i - 1) in + [%logs.app + "Gc ended on commit idx %d with key %a, it took %a" (i - 1) pp_key + gc_commit_key Mtime.Span.pp dt]); + Lwt.return_unit + in + + let rec aux commit_seq i = + match commit_seq () with + | Seq.Nil -> on_end () >|= fun () -> i + | Cons (ops, commit_seq) -> + let really_wait_gc, really_start_gc = + gc_actions config i t.commits_since_start_or_gc + in + let* () = + if really_wait_gc then ( + [%logs.app "Waiting gc while latest commit has idx %d" (i - 1)]; + finalise_gc_and_log ~wait:true i repo) + else Lwt.return_unit + in + let* () = + if really_start_gc then ( + (* Starting GC. + + TODO: If the GC-commit is an orphan commit we will have + problems. *) + let gc_commit_idx = i - config.gc_distance_in_the_past - 1 in + let gc_commit_key = + Hashtbl.find t.key_per_commit_idx gc_commit_idx + in + t.commits_since_start_or_gc <- 0; + [%logs.app + "Starting gc on commit idx %d with key %a while latest commit \ + has idx %d with key %a" + gc_commit_idx pp_key gc_commit_key (i - 1) pp_key + (Hashtbl.find t.key_per_commit_idx (i - 1))]; + Store.gc repo gc_commit_key) + else Lwt.return_unit + in + (* Call finalise_gc after each commit. *) + let* () = finalise_gc_and_log ~wait:false i repo in + + let* () = add_operations t repo ops i stats check_hash empty_blobs in + let len0 = Hashtbl.length t.contexts in + let len1 = Hashtbl.length t.hash_corresps in + if (len0, len1) <> (0, 1) then + [%logs.app + "\nAfter commit %6d we have %d/%d history sizes" i len0 len1]; + let* () = + on_commit i + (Hashtbl.find t.key_per_commit_idx i + |> Store.Backend.Commit.Key.to_hash) + in + t.commits_since_start_or_gc <- t.commits_since_start_or_gc + 1; + prog 1; + aux commit_seq (i + 1) + in + aux commit_seq 0 + + let run : type a. _ -> a config -> a Lwt.t = + fun ext_config config -> + let check_hash = + config.path_conversion = `None + && config.inode_config = (32, 256) + && config.empty_blobs = false + in + [%logs.app + "Will %scheck commit hashes against reference." + (if check_hash then "" else "NOT ")]; + let commit_seq = + open_commit_sequence config.number_of_commits_to_replay + config.path_conversion config.replay_trace_path + in + let root = Filename.concat config.artefacts_path "root" in + let* repo, on_commit, on_end = Store.create_repo ~root ext_config in + prepare_artefacts_dir config.artefacts_path; + let stat_path = Filename.concat config.artefacts_path "stat_trace.repr" in + let c = + let entries, stable_hash = config.inode_config in + Trace_definitions.Stat_trace. + { + setup = + `Replay + { + path_conversion = config.path_conversion; + artefacts_dir = config.artefacts_path; + }; + inode_config = (entries, entries, stable_hash); + store_type = config.store_type; + } + in + let stats = Stat_collector.create_file stat_path c root in + Irmin_pack.Stats.reset_stats (); + Lwt.finalize + (fun () -> + let* block_count = + add_commits config repo commit_seq on_commit on_end stats check_hash + config.empty_blobs + in + [%logs.app "Closing repo..."]; + let+ () = Store.Repo.close repo in + Stat_collector.close stats; + match config.return_type with + | Unit -> (() : a) + | Summary -> + [%logs.app "Computing summary..."]; + Trace_stat_summary.summarise ~block_count stat_path) + (fun () -> + if config.keep_stat_trace then ( + [%logs.app "Stat trace kept at %s" stat_path]; + Unix.chmod stat_path 0o444; + Lwt.return_unit) + else Lwt.return (Stat_collector.remove stats)) +end diff --git a/vendors/irmin/bench/irmin-pack/trace_replay.mli b/vendors/irmin/bench/irmin-pack/trace_replay.mli new file mode 100644 index 0000000000000000000000000000000000000000..e176c9f3871009fe424712c71d387a6a1090313f --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_replay.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Trace_replay_intf.Sigs diff --git a/vendors/irmin/bench/irmin-pack/trace_replay_intf.ml b/vendors/irmin/bench/irmin-pack/trace_replay_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..3148d8343b1e18f80b9b9e061829192e86679331 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_replay_intf.ml @@ -0,0 +1,124 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Config = struct + type _ return_type = + | Unit : unit return_type + | Summary : Trace_stat_summary.t return_type + + type 'a config = { + number_of_commits_to_replay : int; + path_conversion : [ `None | `V1 | `V0_and_v1 | `V0 ]; + inode_config : int * int; + store_type : [ `Pack | `Pack_layered | `Pack_mem ]; + replay_trace_path : string; + artefacts_path : string; + keep_store : bool; + keep_stat_trace : bool; + empty_blobs : bool; + return_type : 'a return_type; + gc_every : int; + gc_distance_in_the_past : int; + gc_wait_after : int; + } + (** Replay configuration + + [replay_trace_path] points to a specific file that describes the sequence + of operations to replay. You may download one of the following URLs. The + smaller ones are prefix of the larger ones. + + - http://data.tarides.com/irmin/data4_10310commits.repr (0.3GB) + - http://data.tarides.com/irmin/data4_100066commits.repr (2.9GB) + - http://data.tarides.com/irmin/data_1343496commits.repr (102GB) + + [number_of_commits_to_replay] is the wished number of commits to replay. + If the value is too high, the replay will stop when reaching the end of + [replay_trace_path]. Pick a number of commits depending on the wished + runtime. Here are some reference runtimes that were true for irmin 3.0: + + - [60_457] commits take 3 minutes + - [500_000] commits take 1 hour + - [1_343_496] commits take 5 hours + + [artefacts_path] is the destination for the stats trace and the store. If + both [keep_store] and [keep_stat_trace] are false, the destination will be + emptied at the end of the replay. + + [path_conversion] is the strategy for shortening the paths while + replaying. Was useful when benchmarking irmin on flattened Tezos paths. + + [empty_blobs] make the replay to push the empty string as in all the + blobs, instead of their actual value read in the trace. + + [inode_config] is a pair of ints that will be stored in the results of the + replay. + + A GC is triggered every [gc_every] commits. When GC is triggered, we + select a previous commit that is [gc_distance_in_the_past] commits away + from the current head commit. + + The first GC will be started after [gc_distance_in_the_past + 1] commits + were replayed. [gc_distance_in_the_past] only makes sense if [gc_every] is + not [0]. + + [gc_wait_after] defines how many commits separate the start of a GC and + the moment we block to wait for it to finish. [0] means that we will only + block when the next gc starts or at the end of the replay. This parameter + only makes sense if [gc_every] is not [0]. *) +end + +module type Config = module type of Config + +include Config + +module type Store = sig + type store_config + type key + + include + Irmin.Generic_key.KV + with type Schema.Contents.t = bytes + and type commit_key = key + and type node_key = key + and type contents_key = key + + type on_commit := int -> Hash.t -> unit Lwt.t + type on_end := unit -> unit Lwt.t + + val create_repo : + root:string -> store_config -> (Repo.t * on_commit * on_end) Lwt.t + + val gc : repo -> commit_key -> unit Lwt.t + val finalise_gc : ?wait:bool -> repo -> bool Lwt.t +end + +module type Sigs = sig + include + Config + with type 'a return_type = 'a return_type + and type 'a config = 'a config + + module type Store = Store + + module Make (Store : Store) : sig + include + Config + with type 'a return_type = 'a return_type + and type 'a config = 'a config + + val run : Store.store_config -> 'a config -> 'a Lwt.t + end +end diff --git a/vendors/irmin/bench/irmin-pack/trace_stat_summary.ml b/vendors/irmin/bench/irmin-pack/trace_stat_summary.ml new file mode 100644 index 0000000000000000000000000000000000000000..74ef2429b0826bc48cabafdccee365205e094aea --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_stat_summary.ml @@ -0,0 +1,1106 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Conversion of a [Stat_trace] to a summary that is both pretty-printable and + exportable to JSON. + + The main type [t] here isn't versioned like a [Stat_trace.t] is. + + Computing a summary may take a long time if the input [Stat_trace] is long. + Count ~1000 commits per second. + + This file is NOT meant to be used from Tezos, as opposed to some other + "trace_*" files. *) + +module Def = Trace_definitions.Stat_trace +module Conf = Trace_stat_summary_conf +module Utils = Trace_stat_summary_utils +module Vs = Utils.Variable_summary +module Seq = Trace_common.Seq + +(* Section 1/4 - Type of a summary. *) + +type curve = Utils.curve [@@deriving repr] + +(** A stat trace can be chunked into {e blocks}. A {e blocks} is made of 2 + phases, first the {e buildup} and then the {e commit}. + + The duration of a {e buildup} can be split into 2 parts: 1. the time spend + in each operation and 2. the sum of the time spent between, before and after + all operations. The first being the {e seen buildup} and the second the + {e unseen buildup}. + + The total duration of a block is the sum of the durations of the {e commit}, + the {e seen buildup} and the {e unseen buildup}. + + Caveat: There isn't a one to one correspondance between summary blocks and + Tezos' blocks. A Tezos block is associated to a commit, but a commit is not + necessarily associated to a Tezos block. There are ~50 more commits than + Tezos blocks up to the Edo protocol. *) +module Span = struct + module Key = struct + type atom_seen = + [ `Add | `Remove | `Find | `Mem | `Mem_tree | `Checkout | `Copy | `Commit ] + [@@deriving repr, enum] + (** The unitary operations played. We recorded the length of all of these. *) + + type atom = [ atom_seen | `Unseen ] + (** [atom_seen] plus the time between operations. The sum of these is the + total time. *) + + type phase = [ `Buildup | `Commit ] + (** The two major phases. The sum of these is the total time *) + + type t = + [ `Add + | `Remove + | `Find + | `Mem + | `Mem_tree + | `Checkout + | `Copy + | `Commit + | `Unseen + | `Buildup + | `Block ] + [@@deriving repr, enum] + (** All spans. + + Redefined (i.e. no inheritance) for derivers. *) + + let all_atoms_seen : atom_seen list = + List.init (max_atom_seen + 1) (fun i -> atom_seen_of_enum i |> Option.get) + + let all : t list = List.init (max + 1) (fun i -> of_enum i |> Option.get) + + let to_string : [< t ] -> string = + fun v -> + match String.split_on_char '"' (Irmin.Type.to_string t v) with + | [ ""; s; "" ] -> s |> String.lowercase_ascii + | _ -> failwith "Could not encode span name to json" + + let of_string : string -> (t, [ `Msg of string ]) result = + fun s -> + let s = "\"" ^ String.capitalize_ascii s ^ "\"" in + match Irmin.Type.of_string t s with Ok v -> Ok v | Error _ as e -> e + end + + module Val = struct + type t = { + count : Vs.t; + cumu_count : Vs.t; + duration : Vs.t; + duration_log_scale : Vs.t; + cumu_duration : Vs.t; + } + [@@deriving repr] + (** The [count] variable is the number of occurences of a span per block and + [cumu_count] is the cumulative from the beginning. + + The [duration] variable is the length of a span occurence and + [cumu_duration] is the cumulative from the beginning. The x axis for the + [evolution] is the number of blocks. + + The [count] for [commit] and [unseen] is trivialy equal to 1. The same + is almost true for [checkout] too. *) + end + + module Map = Map.Make (struct + type t = Key.t + + let compare = compare + end) + + type map = Val.t Map.t + + let map_t : map Irmin.Type.t = + let encode map = + Map.bindings map |> List.map (fun (k, v) -> (Key.to_string k, v)) + in + let decode l = + let key_of_string k = + match Key.of_string k with + | Ok k -> k + | Error (`Msg msg) -> + Fmt.failwith "Could not convert string back to key: %s" msg + in + List.map (fun (k, v) -> (key_of_string k, v)) l + |> List.to_seq + |> Map.of_seq + in + Irmin.Type.(map (Json.assoc Val.t) decode encode) +end + +module Watched_node = struct + module Key = struct + type t = Def.watched_node [@@deriving repr] + + let to_string v = + match String.split_on_char '"' (Irmin.Type.to_string t v) with + | [ ""; s; "" ] -> s |> String.lowercase_ascii + | _ -> failwith "Could not encode node name to json" + + let of_string s = + let s = "\"" ^ String.capitalize_ascii s ^ "\"" in + match Irmin.Type.of_string t s with Ok v -> Ok v | Error _ as e -> e + end + + module Val = struct + type t = { value : Vs.t; diff_per_block : Vs.t } [@@deriving repr] + end + + module Map = Map.Make (struct + type t = Key.t + + let compare = compare + end) + + type map = Val.t Map.t + + let map_t : map Irmin.Type.t = + let encode map = + Map.bindings map |> List.map (fun (k, v) -> (Key.to_string k, v)) + in + let decode l = + let key_of_string k = + match Key.of_string k with + | Ok k -> k + | Error (`Msg msg) -> + Fmt.failwith "Could not convert string back to key: %s" msg + in + List.map (fun (k, v) -> (key_of_string k, v)) l + |> List.to_seq + |> Map.of_seq + in + Irmin.Type.(map (Json.assoc Val.t) decode encode) +end + +type bag_stat = { + value_before_commit : Vs.t; + value_after_commit : Vs.t; + diff_per_block : Vs.t; + diff_per_buildup : Vs.t; + diff_per_commit : Vs.t; +} +[@@deriving repr] +(** Summary of an entry contained in [Def.bag_of_stat]. + + Properties of such a variables: + + - Is sampled before each commit operation. + - Is sampled after each commit operation. + - Is sampled in header. + - Most of these entries are expected to grow linearly, it implies that no + smoothing is necessary for the downsampled curve in these cases, and that + the histogram is best viewed on a linear scale - as opposed to a log + scale. The other entries are summarised using + [~is_linearly_increasing:false]. + + The [value_after_commit] is initially fed with the value in the header (i.e. + the value recorded just before the start of the play). *) + +type finds = { + total : bag_stat; + from_staging : bag_stat; + from_lru : bag_stat; + from_pack_direct : bag_stat; + from_pack_indexed : bag_stat; + missing : bag_stat; + cache_miss : bag_stat; +} +[@@deriving repr] + +type pack = { + finds : finds; + appended_hashes : bag_stat; + appended_offsets : bag_stat; + inode_add : bag_stat; + inode_remove : bag_stat; + inode_of_seq : bag_stat; + inode_of_raw : bag_stat; + inode_rec_add : bag_stat; + inode_rec_remove : bag_stat; + inode_to_binv : bag_stat; + inode_decode_bin : bag_stat; + inode_encode_bin : bag_stat; +} +[@@deriving repr] + +type tree = { + contents_hash : bag_stat; + contents_find : bag_stat; + contents_add : bag_stat; + node_hash : bag_stat; + node_mem : bag_stat; + node_add : bag_stat; + node_find : bag_stat; + node_val_v : bag_stat; + node_val_find : bag_stat; + node_val_list : bag_stat; +} +[@@deriving repr] + +type index = { + bytes_read : bag_stat; + nb_reads : bag_stat; + bytes_written : bag_stat; + nb_writes : bag_stat; + bytes_both : bag_stat; + nb_both : bag_stat; + nb_merge : bag_stat; + cumu_data_bytes : bag_stat; + merge_durations : float list; +} +[@@deriving repr] + +type gc = { + minor_words : bag_stat; + promoted_words : bag_stat; + major_words : bag_stat; + minor_collections : bag_stat; + major_collections : bag_stat; + compactions : bag_stat; + major_heap_bytes : bag_stat; + major_heap_top_bytes : curve; +} +[@@deriving repr] + +type disk = { + index_data : bag_stat; + index_log : bag_stat; + index_log_async : bag_stat; + store_dict : bag_stat; + store_pack : bag_stat; +} +[@@deriving repr] + +type store = { watched_nodes : Watched_node.map } [@@deriving repr] + +type t = { + summary_timeofday : float; + summary_hostname : string; + curves_sample_count : int; + moving_average_half_life_ratio : float; + (* Stats from [Def.header]. *) + config : Def.config; + hostname : string; + word_size : int; + timeofday : float; + timestamp_wall0 : float; + timestamp_cpu0 : float; + (* Stats derived from [Def.row]s. *) + elapsed_wall : float; + elapsed_wall_over_blocks : Utils.curve; + elapsed_cpu : float; + elapsed_cpu_over_blocks : Utils.curve; + op_count : int; + span : Span.map; + block_count : int; + cpu_usage : Vs.t; + index : index; + pack : pack; + tree : tree; + gc : gc; + disk : disk; + store : store; +} +[@@deriving repr] + +(* Section 2/4 - Converters from stat_strace to element of summary. *) +let create_vs block_count = + Vs.create_acc ~distribution_bin_count:Conf.histo_bin_count + ~out_sample_count:Conf.curves_sample_count + ~in_period_count:(block_count + 1) ~evolution_resampling_mode:`Next_neighbor + +let create_vs_exact block_count = + create_vs block_count ~evolution_smoothing:`None ~scale:`Linear + +let create_vs_smooth block_count = + let hlr = Conf.moving_average_half_life_ratio in + let rt = Conf.moving_average_relevance_threshold in + create_vs block_count ~evolution_smoothing:(`Ema (hlr, rt)) ~scale:`Linear + +let create_vs_smooth_log block_count = + let hlr = Conf.moving_average_half_life_ratio in + let rt = Conf.moving_average_relevance_threshold in + create_vs block_count ~evolution_smoothing:(`Ema (hlr, rt)) ~scale:`Log + +(** Accumulator for the [span] field of [t]. *) +module Span_folder = struct + type span_acc = { + sum_count : int; + sum_duration : float; + count : Vs.acc; + cumu_count : Vs.acc; + duration : Vs.acc; + duration_log_scale : Vs.acc; + cumu_duration : Vs.acc; + } + + type acc = { + per_span : span_acc Span.Map.t; + seen_atoms_durations_in_block : float list Span.Map.t; + timestamp_before : float; + } + + let create timestamp_before block_count = + let seen_atoms_durations_in_block0 = + List.map + (fun atom_seen -> (atom_seen, [])) + (Span.Key.all_atoms_seen :> Span.Key.t list) + |> List.to_seq + |> Span.Map.of_seq + in + let acc0 = + let acc0_per_span = + let count = create_vs_smooth block_count in + let count = Vs.accumulate count [] in + let cumu_count = create_vs_exact block_count in + let cumu_count = Vs.accumulate cumu_count [ 0. ] in + let duration = create_vs_smooth block_count in + let duration = Vs.accumulate duration [] in + let duration_log_scale = create_vs_smooth_log block_count in + let duration_log_scale = Vs.accumulate duration_log_scale [] in + let cumu_duration = create_vs_exact block_count in + let cumu_duration = Vs.accumulate cumu_duration [ 0. ] in + { + sum_count = 0; + sum_duration = 0.; + count; + cumu_count; + duration; + duration_log_scale; + cumu_duration; + } + in + let per_span = + List.map (fun span -> (span, acc0_per_span)) Span.Key.all + |> List.to_seq + |> Span.Map.of_seq + in + { + per_span; + seen_atoms_durations_in_block = seen_atoms_durations_in_block0; + timestamp_before; + } + in + + let accumulate acc row = + let on_atom_seen_duration32 acc (span : Span.Key.atom_seen) (d : int32) = + let d = Int32.float_of_bits d in + let span = (span :> Span.Key.t) in + let seen_atoms_durations_in_block = + let m = acc.seen_atoms_durations_in_block in + let l = d :: Span.Map.find span m in + Span.Map.add span l m + in + { acc with seen_atoms_durations_in_block } + in + let on_durations (span : Span.Key.t) (new_durations : float list) acc = + let acc' = Span.Map.find span acc.per_span in + let new_count = List.length new_durations in + let sum_count = acc'.sum_count + new_count in + let sum_duration = + acc'.sum_duration +. List.fold_left ( +. ) 0. new_durations + in + let count = Vs.accumulate acc'.count [ float_of_int new_count ] in + let cumu_count = + Vs.accumulate acc'.cumu_count [ float_of_int sum_count ] + in + let duration = Vs.accumulate acc'.duration new_durations in + let duration_log_scale = + Vs.accumulate acc'.duration_log_scale new_durations + in + let cumu_duration = Vs.accumulate acc'.cumu_duration [ sum_duration ] in + let acc' = + { + sum_count; + sum_duration; + count; + cumu_count; + duration; + duration_log_scale; + cumu_duration; + } + in + { acc with per_span = Span.Map.add span acc' acc.per_span } + in + let on_commit (c : Def.commit) acc = + let list_one span = + Span.Map.find span acc.seen_atoms_durations_in_block + in + let sum_one span = List.fold_left ( +. ) 0. (list_one span) in + let sum_several spans = + let spans = (spans :> Span.Key.t list) in + List.fold_left (fun cumu span -> cumu +. sum_one span) 0. spans + in + let total_duration = c.after.timestamp_wall -. acc.timestamp_before in + let acc = + acc + |> on_durations `Add (list_one `Add) + |> on_durations `Remove (list_one `Remove) + |> on_durations `Find (list_one `Find) + |> on_durations `Mem (list_one `Mem) + |> on_durations `Mem_tree (list_one `Mem_tree) + |> on_durations `Checkout (list_one `Checkout) + |> on_durations `Copy (list_one `Copy) + |> on_durations `Commit (list_one `Commit) + |> on_durations `Unseen + [ total_duration -. sum_several Span.Key.all_atoms_seen ] + |> on_durations `Buildup [ total_duration -. sum_one `Commit ] + |> on_durations `Block [ total_duration ] + in + { + acc with + seen_atoms_durations_in_block = seen_atoms_durations_in_block0; + timestamp_before = c.after.timestamp_wall; + } + in + match row with + | `Add d -> on_atom_seen_duration32 acc `Add d + | `Remove d -> on_atom_seen_duration32 acc `Remove d + | `Find d -> on_atom_seen_duration32 acc `Find d + | `Mem d -> on_atom_seen_duration32 acc `Mem d + | `Mem_tree d -> on_atom_seen_duration32 acc `Mem_tree d + | `Checkout d -> on_atom_seen_duration32 acc `Checkout d + | `Copy d -> on_atom_seen_duration32 acc `Copy d + | `Commit c -> + on_atom_seen_duration32 acc `Commit c.Def.duration |> on_commit c + in + + let finalise { per_span; _ } = + Span.Map.map + (fun acc -> + { + Span.Val.count = Vs.finalise acc.count; + cumu_count = Vs.finalise acc.cumu_count; + duration = Vs.finalise acc.duration; + duration_log_scale = Vs.finalise acc.duration_log_scale; + cumu_duration = Vs.finalise acc.cumu_duration; + }) + per_span + in + + Utils.Parallel_folders.folder acc0 accumulate finalise +end + +(** Summary computation for statistics recorded in [Def.bag_of_stat]. *) +module Bag_stat_folder = struct + type acc = { + value_before_commit : Vs.acc; + value_after_commit : Vs.acc; + diff_per_block : Vs.acc; + diff_per_buildup : Vs.acc; + diff_per_commit : Vs.acc; + prev_value : float; + (* constants *) + value_of_bag : Def.bag_of_stats -> float; + should_cumulate_value : bool; + } + + let create_acc ?(is_linearly_increasing = true) + ?(should_cumulate_value = false) header block_count value_of_bag = + let value_in_header = value_of_bag header.Def.initial_stats in + let f = + if is_linearly_increasing then create_vs_exact else create_vs_smooth + in + let value_before_commit = f block_count in + let value_before_commit = Vs.accumulate value_before_commit [] in + let value_after_commit = f block_count in + let value_after_commit = + Vs.accumulate value_after_commit [ value_in_header ] + in + let diff_per_block = create_vs_smooth block_count in + let diff_per_block = Vs.accumulate diff_per_block [] in + let diff_per_buildup = create_vs_smooth block_count in + let diff_per_buildup = Vs.accumulate diff_per_buildup [] in + let diff_per_commit = create_vs_smooth block_count in + let diff_per_commit = Vs.accumulate diff_per_commit [] in + { + value_before_commit; + value_after_commit; + diff_per_block; + diff_per_buildup; + diff_per_commit; + prev_value = value_in_header; + value_of_bag; + should_cumulate_value; + } + + let accumulate acc row = + match row with + | `Commit c -> + let va = acc.value_of_bag c.Def.before in + let vb = acc.value_of_bag c.Def.after in + let va, vb = + if acc.should_cumulate_value then + (acc.prev_value +. va, acc.prev_value +. va +. vb) + else (va, vb) + in + let diff_block = vb -. acc.prev_value in + let diff_buildup = va -. acc.prev_value in + let diff_commit = vb -. va in + let value_before_commit = + Vs.accumulate acc.value_before_commit [ va ] + in + let value_after_commit = Vs.accumulate acc.value_after_commit [ vb ] in + let diff_per_block = Vs.accumulate acc.diff_per_block [ diff_block ] in + let diff_per_buildup = + Vs.accumulate acc.diff_per_buildup [ diff_buildup ] + in + let diff_per_commit = + Vs.accumulate acc.diff_per_commit [ diff_commit ] + in + { + acc with + value_before_commit; + value_after_commit; + diff_per_block; + diff_per_buildup; + diff_per_commit; + prev_value = vb; + } + | _ -> acc + + let finalise acc : bag_stat = + { + value_before_commit = Vs.finalise acc.value_before_commit; + value_after_commit = Vs.finalise acc.value_after_commit; + diff_per_block = Vs.finalise acc.diff_per_block; + diff_per_buildup = Vs.finalise acc.diff_per_buildup; + diff_per_commit = Vs.finalise acc.diff_per_commit; + } + + let create ?should_cumulate_value ?is_linearly_increasing header block_count + value_of_bag = + let acc0 = + create_acc ?should_cumulate_value ?is_linearly_increasing header + block_count value_of_bag + in + Utils.Parallel_folders.folder acc0 accumulate finalise +end + +(** Accumulator for the [store] field of [t]. *) +module Store_watched_nodes_folder = struct + type acc_per_node = { + value : Vs.acc; + diff_per_block : Vs.acc; + prev_value : float; + } + + type acc = acc_per_node list + + let create_acc block_count = + let acc0_per_node = + let value = create_vs_exact block_count in + let value = Vs.accumulate value [] in + let diff_per_block = create_vs_smooth block_count in + let diff_per_block = Vs.accumulate diff_per_block [] in + { value; diff_per_block; prev_value = Float.nan } + in + List.map (Fun.const acc0_per_node) Def.watched_nodes + + let accumulate acc row = + match row with + | `Commit c -> + let accumulate_per_node v acc = + let v = float_of_int v in + let diff_block = v -. acc.prev_value in + let value = Vs.accumulate acc.value [ v ] in + let diff_per_block = + Vs.accumulate acc.diff_per_block [ diff_block ] + in + { value; diff_per_block; prev_value = v } + in + List.map2 accumulate_per_node c.Def.store_after.watched_nodes_length acc + | _ -> acc + + let finalise acc : Watched_node.map = + List.map2 + (fun k acc -> + let v = + { + Watched_node.Val.value = Vs.finalise acc.value; + diff_per_block = Vs.finalise acc.diff_per_block; + } + in + (k, v)) + Def.watched_nodes acc + |> List.to_seq + |> Watched_node.Map.of_seq + + let create block_count = + let acc0 = create_acc block_count in + Utils.Parallel_folders.folder acc0 accumulate finalise +end + +(** Build a resampled curve of [gc.top_heap_words] *) +let major_heap_top_bytes_folder header block_count = + let ws = header.Def.word_size / 8 |> float_of_int in + let len0 = block_count + 1 in + let len1 = Conf.curves_sample_count in + let v0 = float_of_int header.Def.initial_stats.gc.top_heap_words *. ws in + let acc0 = Utils.Resample.create_acc `Next_neighbor ~len0 ~len1 ~v00:v0 in + let accumulate acc = function + | `Commit c -> + Utils.Resample.accumulate acc + (float_of_int c.Def.after.gc.top_heap_words *. ws) + | _ -> acc + in + let finalise = Utils.Resample.finalise in + Utils.Parallel_folders.folder acc0 accumulate finalise + +(** Build a resampled curve of timestamps. *) +let elapsed_wall_over_blocks_folder header block_count = + let open Def in + let len0 = block_count + 1 in + let len1 = Conf.curves_sample_count in + let v0 = header.initial_stats.timestamp_wall in + let acc0 = Utils.Resample.create_acc `Interpolate ~len0 ~len1 ~v00:v0 in + let accumulate acc = function + | `Commit c -> Utils.Resample.accumulate acc c.after.timestamp_wall + | _ -> acc + in + let finalise acc = + Utils.Resample.finalise acc |> List.map (fun t -> t -. v0) + in + Utils.Parallel_folders.folder acc0 accumulate finalise + +(** Build a resampled curve of timestamps. *) +let elapsed_cpu_over_blocks_folder header block_count = + let open Def in + let len0 = block_count + 1 in + let len1 = Conf.curves_sample_count in + let v0 = header.initial_stats.timestamp_cpu in + let acc0 = Utils.Resample.create_acc `Interpolate ~len0 ~len1 ~v00:v0 in + let accumulate acc = function + | `Commit c -> Utils.Resample.accumulate acc c.after.timestamp_cpu + | _ -> acc + in + let finalise acc = + Utils.Resample.finalise acc |> List.map (fun t -> t -. v0) + in + Utils.Parallel_folders.folder acc0 accumulate finalise + +(** Build a list of all the merge durations. *) +let merge_durations_folder = + let acc0 = [] in + let accumulate l = function + | `Commit c -> + let l = List.rev_append c.Def.before.index.new_merge_durations l in + let l = List.rev_append c.Def.after.index.new_merge_durations l in + l + | _ -> l + in + let finalise = List.rev in + Utils.Parallel_folders.folder acc0 accumulate finalise + +let cpu_usage_folder header block_count = + let acc0 = + let vs = create_vs_smooth block_count in + let vs = Vs.accumulate vs [] in + ( header.Def.initial_stats.timestamp_wall, + header.Def.initial_stats.timestamp_cpu, + vs ) + in + let accumulate ((prev_wall, prev_cpu, vs) as acc) = function + | `Commit c -> + let span_wall = c.Def.after.timestamp_wall -. prev_wall in + let span_cpu = c.Def.after.timestamp_cpu -. prev_cpu in + ( c.Def.after.timestamp_wall, + c.Def.after.timestamp_cpu, + Vs.accumulate vs [ span_cpu /. span_wall ] ) + | _ -> acc + in + let finalise (_, _, vs) = Vs.finalise vs in + Utils.Parallel_folders.folder acc0 accumulate finalise + +(** Substract the first and the last timestamps and count the number of span. *) +let misc_stats_folder header = + let open Def in + let acc0 = (0., 0., 0) in + let accumulate (t, t', count) = function + | `Commit c -> (c.after.timestamp_wall, c.after.timestamp_cpu, count + 1) + | _ -> (t, t', count + 1) + in + let finalise (t, t', count) = + ( t -. header.initial_stats.timestamp_wall, + t' -. header.initial_stats.timestamp_cpu, + count ) + in + Utils.Parallel_folders.folder acc0 accumulate finalise + +(* Section 3/4 - Converter from stat_strace to summary *) + +(** Fold over [row_seq] and produce the summary. + + {3 Parallel Folders} + + Almost all entries in [t] require to independently fold over the rows of the + stat trace, but we want: + + - not to fully load the trace in memory, + - not to reread the trace from disk once for each entry, + - this current file to be verbose and simple, + - to have fun with GADTs and avoid mutability. + + All the boilerplate is hidden behind [Utils.Parallel_folders], a + datastructure that holds all folder functions, takes care of feeding the + rows to those folders, and preseves the types. + + In the code below, [pf0] is the initial parallel folder, before the first + accumulation. Each [|+ ...] statement declares a [acc, accumulate, finalise] + triplet, i.e. a folder. + + [val acc : acc] is the initial empty accumulation of a folder. + + [val accumulate : acc -> row -> acc] needs to be folded over all rows of the + stat trace. Calling [Parallel_folders.accumulate pf row] will feed [row] to + every folders. + + [val finalise : acc -> v] has to be applied on the final [acc] of a folder + in order to produce the final value of that folder - which value is meant to + be stored in [Trace_stat_summary.t]. Calling [Parallel_folders.finalise pf] + will finalise all folders and pass their result to [construct]. *) +let summarise' header block_count (row_seq : Def.row Seq.t) = + let bs_folder_of_bag_getter ?should_cumulate_value ?is_linearly_increasing + value_of_bag = + Bag_stat_folder.create ?should_cumulate_value ?is_linearly_increasing header + block_count value_of_bag + in + + let finds_folder = + let construct total from_staging from_lru from_pack_direct from_pack_indexed + missing cache_miss = + { + total; + from_staging; + from_lru; + from_pack_direct; + from_pack_indexed; + missing; + cache_miss; + } + in + let acc0 = + let open Utils.Parallel_folders in + let ofi = float_of_int in + open_ construct + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.finds.total) + |+ bs_folder_of_bag_getter (fun bag -> + ofi bag.Def.pack.finds.from_staging) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.finds.from_lru) + |+ bs_folder_of_bag_getter (fun bag -> + ofi bag.Def.pack.finds.from_pack_direct) + |+ bs_folder_of_bag_getter (fun bag -> + ofi bag.Def.pack.finds.from_pack_indexed) + |+ bs_folder_of_bag_getter (fun bag -> + let open Def in + let v = bag.pack.finds in + v.total + - v.from_staging + - v.from_lru + - v.from_pack_direct + - v.from_pack_indexed + |> ofi) + |+ bs_folder_of_bag_getter (fun bag -> + let open Def in + let v = bag.pack.finds in + v.total - v.from_staging - v.from_lru |> ofi) + |> seal + in + Utils.Parallel_folders.folder acc0 Utils.Parallel_folders.accumulate + Utils.Parallel_folders.finalise + in + + let pack_folder = + let construct finds appended_hashes appended_offsets inode_add inode_remove + inode_of_seq inode_of_raw inode_rec_add inode_rec_remove inode_to_binv + inode_decode_bin inode_encode_bin = + { + finds; + appended_hashes; + appended_offsets; + inode_add; + inode_remove; + inode_of_seq; + inode_of_raw; + inode_rec_add; + inode_rec_remove; + inode_to_binv; + inode_decode_bin; + inode_encode_bin; + } + in + let acc0 = + let open Utils.Parallel_folders in + let ofi = float_of_int in + open_ construct + |+ finds_folder + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.appended_hashes) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.appended_offsets) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.inode_add) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.inode_remove) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.inode_of_seq) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.inode_of_raw) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.inode_rec_add) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.inode_rec_remove) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.inode_to_binv) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.inode_decode_bin) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.pack.inode_encode_bin) + |> seal + in + Utils.Parallel_folders.folder acc0 Utils.Parallel_folders.accumulate + Utils.Parallel_folders.finalise + in + + let tree_folder = + let construct contents_hash contents_find contents_add node_hash node_mem + node_add node_find node_val_v node_val_find node_val_list = + { + contents_hash; + contents_find; + contents_add; + node_hash; + node_mem; + node_add; + node_find; + node_val_v; + node_val_find; + node_val_list; + } + in + let acc0 = + let open Utils.Parallel_folders in + let ofi = float_of_int in + open_ construct + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.tree.contents_hash) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.tree.contents_find) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.tree.contents_add) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.tree.node_hash) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.tree.node_mem) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.tree.node_add) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.tree.node_find) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.tree.node_val_v) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.tree.node_val_find) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.tree.node_val_list) + |> seal + in + Utils.Parallel_folders.folder acc0 Utils.Parallel_folders.accumulate + Utils.Parallel_folders.finalise + in + + let index_folder = + let construct bytes_read nb_reads bytes_written nb_writes bytes_both nb_both + nb_merge cumu_data_bytes merge_durations = + { + bytes_read; + nb_reads; + bytes_written; + nb_writes; + bytes_both; + nb_both; + nb_merge; + cumu_data_bytes; + merge_durations; + } + in + let acc0 = + let open Utils.Parallel_folders in + let ofi = float_of_int in + open_ construct + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.index.bytes_read) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.index.nb_reads) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.index.bytes_written) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.index.nb_writes) + |+ bs_folder_of_bag_getter (fun bag -> + ofi (bag.Def.index.bytes_read + bag.Def.index.bytes_written)) + |+ bs_folder_of_bag_getter (fun bag -> + ofi (bag.Def.index.nb_reads + bag.Def.index.nb_writes)) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.index.nb_merge) + |+ bs_folder_of_bag_getter ~should_cumulate_value:true (fun bag -> + (* When 1 merge occured, [data_size] bytes were written. + + When 2 merge occured, [data_size * 2 - log_size] bytes were + written. But here we just count [data_size * 2]. *) + let merge_count = + List.length bag.Def.index.new_merge_durations |> Int64.of_int + in + let data_size = bag.Def.disk.index_data in + Int64.to_float (Int64.mul merge_count data_size)) + |+ merge_durations_folder + |> seal + in + Utils.Parallel_folders.folder acc0 Utils.Parallel_folders.accumulate + Utils.Parallel_folders.finalise + in + + let gc_folder = + let construct minor_words promoted_words major_words minor_collections + major_collections compactions major_heap_bytes major_heap_top_bytes = + { + minor_words; + promoted_words; + major_words; + minor_collections; + major_collections; + compactions; + major_heap_bytes; + major_heap_top_bytes; + } + in + let acc0 = + let open Utils.Parallel_folders in + let ofi = float_of_int in + let ws = header.Def.word_size / 8 |> float_of_int in + open_ construct + |+ bs_folder_of_bag_getter (fun bag -> bag.Def.gc.minor_words) + |+ bs_folder_of_bag_getter (fun bag -> bag.Def.gc.promoted_words) + |+ bs_folder_of_bag_getter (fun bag -> bag.Def.gc.major_words) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.gc.minor_collections) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.gc.major_collections) + |+ bs_folder_of_bag_getter (fun bag -> ofi bag.Def.gc.compactions) + |+ bs_folder_of_bag_getter ~is_linearly_increasing:false (fun bag -> + ofi bag.Def.gc.heap_words *. ws) + |+ major_heap_top_bytes_folder header block_count + |> seal + in + Utils.Parallel_folders.folder acc0 Utils.Parallel_folders.accumulate + Utils.Parallel_folders.finalise + in + + let disk_folder = + let construct index_data index_log index_log_async store_dict store_pack = + { index_data; index_log; index_log_async; store_dict; store_pack } + in + let acc0 = + let open Utils.Parallel_folders in + let ofi64 = Int64.to_float in + open_ construct + |+ bs_folder_of_bag_getter (fun bag -> ofi64 bag.Def.disk.index_data) + |+ bs_folder_of_bag_getter ~is_linearly_increasing:false (fun bag -> + ofi64 bag.Def.disk.index_log) + |+ bs_folder_of_bag_getter ~is_linearly_increasing:false (fun bag -> + ofi64 bag.Def.disk.index_log_async) + |+ bs_folder_of_bag_getter (fun bag -> ofi64 bag.Def.disk.store_dict) + |+ bs_folder_of_bag_getter (fun bag -> + (* This would not be linearly increasing with irmin layers *) + ofi64 bag.Def.disk.store_pack) + |> seal + in + Utils.Parallel_folders.folder acc0 Utils.Parallel_folders.accumulate + Utils.Parallel_folders.finalise + in + + let construct (elapsed_wall, elapsed_cpu, op_count) elapsed_wall_over_blocks + elapsed_cpu_over_blocks span cpu_usage_variable pack tree index gc disk + watched_nodes = + { + summary_hostname = Unix.gethostname (); + summary_timeofday = Unix.gettimeofday (); + elapsed_wall; + elapsed_cpu; + op_count; + block_count; + curves_sample_count = Conf.curves_sample_count; + moving_average_half_life_ratio = Conf.moving_average_half_life_ratio; + config = header.config; + hostname = header.hostname; + word_size = header.word_size; + timeofday = header.timeofday; + timestamp_wall0 = header.initial_stats.timestamp_wall; + timestamp_cpu0 = header.initial_stats.timestamp_cpu; + elapsed_wall_over_blocks; + elapsed_cpu_over_blocks; + span; + pack; + tree; + cpu_usage = cpu_usage_variable; + index; + gc; + disk; + store = { watched_nodes }; + } + in + + let pf0 = + let open Utils.Parallel_folders in + open_ construct + |+ misc_stats_folder header + |+ elapsed_wall_over_blocks_folder header block_count + |+ elapsed_cpu_over_blocks_folder header block_count + |+ Span_folder.create header.initial_stats.timestamp_wall block_count + |+ cpu_usage_folder header block_count + |+ pack_folder + |+ tree_folder + |+ index_folder + |+ gc_folder + |+ disk_folder + |+ Store_watched_nodes_folder.create block_count + |> seal + in + Seq.fold_left Utils.Parallel_folders.accumulate pf0 row_seq + |> Utils.Parallel_folders.finalise + +(** Turn a stat trace into a summary. + + The number of blocks to consider may be provided in order to truncate the + summary. *) +let summarise ?block_count trace_stat_path = + let block_count = + match block_count with + | Some block_count -> block_count + | None -> + (* The trace has to be iterated a first time in order to retrieve the + * number of blocks. This is needed to: + * - define the moving average momentum, + * - stop the row sequence immediately after the last commit. *) + Trace_definitions.Stat_trace.open_reader trace_stat_path + |> snd + |> Seq.fold_left + (fun count op -> + match op with `Commit _ -> count + 1 | _ -> count) + 0 + in + if block_count <= 0 then invalid_arg "Can't summarise an empty stat trace"; + let header, row_seq = + Trace_definitions.Stat_trace.open_reader trace_stat_path + in + let row_seq = + let aux (seq, commit_count) = + if commit_count >= block_count then None + else + match seq () with + | Seq.Nil -> + failwith + "summarise reached the end of the stat trace before \ + 'block_count' commits were seen" + | Seq.Cons ((`Commit _ as op), seq) -> Some (op, (seq, commit_count + 1)) + | Seq.Cons (op, seq) -> Some (op, (seq, commit_count)) + in + Seq.unfold aux (row_seq, 0) + in + summarise' header block_count row_seq + +(* Section 4/4 - Conversion from summary to json file *) + +let save_to_json v path = + let j = Fmt.str "%a\n" (Irmin.Type.pp_json t) v in + let chan = open_out path in + output_string chan j; + [%logs.app "Summary saved to %s" path]; + close_out chan; + Unix.chmod path 0o444 diff --git a/vendors/irmin/bench/irmin-pack/trace_stat_summary_cb.ml b/vendors/irmin/bench/irmin-pack/trace_stat_summary_cb.ml new file mode 100644 index 0000000000000000000000000000000000000000..da86d33454b45fdf802315b85f4ebd86fbb60dde --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_stat_summary_cb.ml @@ -0,0 +1,247 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Summary = Trace_stat_summary +module Utils = Trace_stat_summary_utils + +type metrics = (string * float list) list [@@deriving repr] + +let metrics_t = Irmin.Type.(Json.assoc (list float)) + +type result = { name : string; metrics : metrics } [@@deriving repr] +type t = { results : (result[@nobuiltin]) list } [@@deriving repr] + +(** As of may 2021, outputing "nan" strings in place of numbers crashes the CB. + Let's just filter those out since this is functionally identical. *) +let filter_nans_out results = + List.map + (fun { name; metrics } -> + let metrics = + List.map + (fun (name, l) -> + (name, match l with [ v ] when Float.is_nan v -> [] | l -> l)) + metrics + in + { name; metrics }) + results + +let create_raw_results0 s : result list = + let open Summary in + [ + { + name = "Trace Replay - main metrics"; + metrics = + [ + ("CPU time elapsed (s)", [ s.elapsed_cpu ]); + ( "TZ-transactions per sec", + [ + (Utils.approx_transaction_count_of_block_count s.block_count + |> float_of_int) + /. s.elapsed_cpu; + ] ); + ( "TZ-operations per sec", + [ + (Utils.approx_operation_count_of_block_count s.block_count + |> float_of_int) + /. s.elapsed_cpu; + ] ); + ( "Context.set per sec", + [ + fst (Span.Map.find `Add s.span).cumu_count.max_value + /. s.elapsed_cpu; + ] ); + ( "tail latency (s)", + [ fst (Span.Map.find `Commit s.span).duration.max_value ] ); + ]; + }; + { + name = "Trace Replay - resource usage - disk IO (total)"; + metrics = + [ + ( "IOPS (op/s)", + [ s.index.nb_both.value_after_commit.diff /. s.elapsed_cpu ] ); + ( "throughput (MB/s)", + [ + s.index.bytes_both.value_after_commit.diff /. s.elapsed_cpu /. 1e6; + ] ); + ("total (MB)", [ s.index.bytes_both.value_after_commit.diff /. 1e6 ]); + ]; + }; + { + name = "Trace Replay - resource usage - disk IO (read)"; + metrics = + [ + ( "IOPS (op/s)", + [ s.index.nb_reads.value_after_commit.diff /. s.elapsed_cpu ] ); + ( "throughput (MB/s)", + [ + s.index.bytes_read.value_after_commit.diff /. s.elapsed_cpu /. 1e6; + ] ); + ("total (MB)", [ s.index.bytes_read.value_after_commit.diff /. 1e6 ]); + ]; + }; + { + name = "Trace Replay - resource usage - disk IO (write)"; + metrics = + [ + ( "IOPS (op/s)", + [ s.index.nb_writes.value_after_commit.diff /. s.elapsed_cpu ] ); + ( "throughput (MB/s)", + [ + s.index.bytes_written.value_after_commit.diff + /. s.elapsed_cpu + /. 1e6; + ] ); + ( "total (MB)", + [ s.index.bytes_written.value_after_commit.diff /. 1e6 ] ); + ]; + }; + { + name = "Trace Replay - resource usage - misc."; + metrics = + [ + ( "max memory usage (GB)", + [ List.fold_left max 0. s.gc.major_heap_top_bytes /. 1e9 ] ); + ("mean CPU usage", [ s.elapsed_cpu /. s.elapsed_wall ]); + ]; + }; + ] + +let create_raw_results1 s : result list = + let a = + let name = "Trace Replay - Context Phases Length" in + let open Trace_stat_summary in + let metrics = + [ `Block; `Buildup; `Commit ] + |> List.map @@ fun k -> + let vs = Span.(Map.find k s.span).duration in + ( Printf.sprintf "%s (ms)" (Span.Key.to_string k), + [ + vs.mean *. 1000. + (* TODO: {min / max / avg}, maybe on a log scale? *); + ] ) + in + { name; metrics } + in + let b = + let name = "Trace Replay - Context Buildup Lengths" in + let open Trace_stat_summary in + let metrics = + [ `Add; `Remove; `Find; `Mem; `Mem_tree; `Copy; `Unseen ] + |> List.map @@ fun k -> + let vs = Span.(Map.find k s.span).duration in + ( Printf.sprintf "%s (\xc2\xb5s)" (Span.Key.to_string k), + [ + vs.mean *. 1e6 (* TODO: {min / max / avg}, maybe on a log scale? *); + ] ) + in + { name; metrics } + in + [ a; b ] + +let create_raw_results2 s : result list = + let name = "Trace Replay - irmin-pack Global Stats" in + let metrics = + let open Summary in + [ + ("finds", s.pack.finds.total); + ("finds.from_staging", s.pack.finds.from_staging); + ("finds.from_lru", s.pack.finds.from_lru); + ("finds.from_pack_direct", s.pack.finds.from_pack_direct); + ("finds.from_pack_indexed", s.pack.finds.from_pack_indexed); + ("finds.missing", s.pack.finds.missing); + ("finds.cache_miss", s.pack.finds.cache_miss); + ("appended_hashes", s.pack.appended_hashes); + ("appended_offsets", s.pack.appended_offsets); + ("inode_add", s.pack.inode_add); + ("inode_remove", s.pack.inode_remove); + ("inode_of_seq", s.pack.inode_of_seq); + ("inode_of_raw", s.pack.inode_of_raw); + ("inode_rec_add", s.pack.inode_rec_add); + ("inode_rec_remove", s.pack.inode_rec_remove); + ("inode_to_binv", s.pack.inode_to_binv); + ("inode_decode_bin", s.pack.inode_decode_bin); + ("inode_encode_bin", s.pack.inode_encode_bin); + ] + |> List.map @@ fun (name, lbs) -> (name, [ lbs.value_after_commit.diff ]) + in + [ { name; metrics } ] + +let create_raw_results3 s : result list = + let name = "Trace Replay - irmin.tree Global Stats" in + let open Trace_stat_summary in + let metrics = + [ + ("contents_hash", s.tree.contents_hash); + ("contents_find", s.tree.contents_find); + ("contents_add", s.tree.contents_add); + ("node_hash", s.tree.node_hash); + ("node_mem", s.tree.node_mem); + ("node_add", s.tree.node_add); + ("node_find", s.tree.node_find); + ("node_val_v", s.tree.node_val_v); + ("node_val_find", s.tree.node_val_find); + ("node_val_list", s.tree.node_val_list); + ] + |> List.map @@ fun (name, lbs) -> (name, [ lbs.value_after_commit.diff ]) + in + [ { name; metrics } ] + +let create_raw_results4 s : result list = + let name = "Trace Replay - index Stats" in + let open Trace_stat_summary in + let metrics = + [ + ( "cumu data MB", + [ fst s.index.cumu_data_bytes.value_after_commit.max_value *. 1e-6 ] ); + ("merge count", [ s.index.nb_merge.value_after_commit.diff ]); + ] + in + [ { name; metrics } ] + +let create_raw_results5 s : result list = + let name = "Trace Replay - GC Stats" in + let open Trace_stat_summary in + let metrics = + [ + ("minor words allocated", s.gc.minor_words); + ("major words allocated", s.gc.major_words); + ("minor collections", s.gc.minor_collections); + ("major collections", s.gc.major_collections); + ("promoted words", s.gc.promoted_words); + ("compactions", s.gc.compactions); + ] + |> List.map @@ fun (name, lbs) -> (name, [ lbs.value_after_commit.diff ]) + in + let metrics' = + [ + ( "avg major heap MB after commit", + [ s.gc.major_heap_bytes.value_after_commit.mean /. 1e6 ] ); + ] + in + [ { name; metrics = metrics @ metrics' } ] + +let of_summary s = + { + results = + create_raw_results0 s + @ create_raw_results1 s + @ create_raw_results2 s + @ create_raw_results3 s + @ create_raw_results4 s + @ create_raw_results5 s + |> filter_nans_out; + } diff --git a/vendors/irmin/bench/irmin-pack/trace_stat_summary_conf.ml b/vendors/irmin/bench/irmin-pack/trace_stat_summary_conf.ml new file mode 100644 index 0000000000000000000000000000000000000000..f6afd1912d10f706653ecc2638fbf2bfd9f98c3b --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_stat_summary_conf.ml @@ -0,0 +1,42 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Summary configuration. + + This file is NOT meant to be used from Tezos, as opposed to some other + "trace_*" files. *) + +let histo_bin_count = 16 +let curves_sample_count = 201 + +(** Parameter to control the width of the moving average window. + + This width is expressed as a fraction of the width of the final plot images, + (i.e. the number of played blocks). This implies that the amount of + smoothing remains visually the same, no matter [curves_sample_count] and the + number of blocks in the stat trace. + + Justification of the current value: + + The 2nd commit of the full replay trace is a massive one, it contains ~1000x + more operations than an average one, it takes ~10 half lives to fully get + rid of it from the EMAs. With [moving_average_half_life_ratio = 1. /. 80.], + that 2nd commit will only poluate [1 / 8] of the width of the smoothed + curves. *) +let moving_average_half_life_ratio = 1. /. 80. + +(** See [Exponential_moving_average] *) +let moving_average_relevance_threshold = 0.999 diff --git a/vendors/irmin/bench/irmin-pack/trace_stat_summary_pp.ml b/vendors/irmin/bench/irmin-pack/trace_stat_summary_pp.ml new file mode 100644 index 0000000000000000000000000000000000000000..2e4ec97cf430f17ca1eeaca6e38bc4afc3a7e15c --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_stat_summary_pp.ml @@ -0,0 +1,1114 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Pretty printing of one or more summaries. + + This file is NOT meant to be used from Tezos, as opposed to some other + "trace_*" files. + + This file contains A LOT of uninteresting boilerplate in order to build the + pretty-printable table. Doing this using pandas-like multi-level dataframes + would make the thing much more simpler. *) + +open Trace_stat_summary +module Utils = Trace_stat_summary_utils +module Summary = Trace_stat_summary + +module Pb = struct + include PrintBox + + (* Some utilities to work with lists instead of array *) + + let transpose_matrix l = + l + |> List.map Array.of_list + |> Array.of_list + |> PrintBox.transpose + |> Array.to_list + |> List.map Array.to_list + + let matrix_to_text m = List.map (List.map PrintBox.text) m + let align_matrix where = List.map (List.map (PrintBox.align ~h:where ~v:`Top)) + + (** Dirty trick to only have vertical bars, and not the horizontal ones *) + let matrix_with_column_spacers = + let rec interleave sep = function + | ([ _ ] | []) as l -> l + | hd :: tl -> hd :: sep :: interleave sep tl + in + List.map (fun l -> + PrintBox.text " | " :: interleave (PrintBox.text " | ") l) +end + +let fprintf_result ppf = + Format.fprintf ppf + {|
+ Setups + +%s +
+ + +%s + + - (1) Longest Context.commit. + - The "per sec" stats are calculated over CPU time. + - "TZ-transactions" and "TZ-operations" are approximations. + - "max memory usage" is the max size of OCaml's major heap. + - "mean CPU usage" is inexact. + +-- global -- +%s + +%s + +-- evolution through blocks -- +%s + +Types of curves: + *C: Cumulative. No smoothing. + *LA: Local Average. Smoothed using a weighted sum of the value in the + block and the exponentially decayed values of the previous blocks. + Every %.2f blocks, half of the past is forgotten. + *S: Size. E.g. directory entries, file bytes. No smoothing. + *N: Very noisy.|} + +type summary = Summary.t + +type scalar_format_fixed = [ `SM | `S3 | `Sm | `Su | `RG | `RM | `Ri | `R3 | `P ] +(** Seconds minutes, Seconds 3 digits, Seconds milli, Seconds micro, Real giga, + Real mega, Real as integer, Real 3 digits, Percent *) + +let pp_scalar_fixed ppf (format, v) = + if Float.is_nan v then Format.fprintf ppf "n/a" + else if Float.is_infinite v then Format.fprintf ppf "%f" v + else if v = 0. then Format.fprintf ppf "0" + else + match format with + | `SM -> + let m = Float.floor (v /. 60.) in + let s = v -. (m *. 60.) in + Format.fprintf ppf "%.0fm%02.0fs" m s + | `S3 -> Format.fprintf ppf "%.3f s" v + | `Sm -> Format.fprintf ppf "%.3f ms" (v *. 1e3) + | `Su -> Format.fprintf ppf "%.3f \xc2\xb5s" (v *. 1e6) + | `RG -> Format.fprintf ppf "%.3f G" (v /. 1e9) + | `RM -> Format.fprintf ppf "%.3f M" (v /. 1e6) + | `Ri -> Format.fprintf ppf "%#d" (Float.round v |> int_of_float) + | `R3 -> Format.fprintf ppf "%.3f" v + | `P -> Format.fprintf ppf "%.0f%%" (v *. 100.) + +(** Summary *) +module Table0 = struct + let summary_config_entries = + [ + `Hostname; + `Word_size; + `Timeofday; + `Inode_config; + `Store_type; + `Replay_path_conversion; + ] + + let name_of_summary_config_entry = function + | `Hostname -> "Hostname" + | `Word_size -> "Word Size" + | `Timeofday -> "Start Time" + | `Inode_config -> "Inode Config" + | `Store_type -> "Store Type" + | `Replay_path_conversion -> "Path Conversion" + + let cell_of_summary_config (s : summary) = function + | `Hostname -> s.hostname + | `Word_size -> Printf.sprintf "%d bits" s.word_size + | `Timeofday -> + let open Unix in + let t = gmtime s.timeofday in + Printf.sprintf "%04d/%02d/%02d %02d:%02d:%02d (GMT)" (1900 + t.tm_year) + (t.tm_mon + 1) t.tm_mday t.tm_hour t.tm_min t.tm_sec + | `Inode_config -> + let a, b, c = s.config.inode_config in + Printf.sprintf "mls:%d bf:%d sh:%d" a b c + | `Store_type -> ( + match s.config.store_type with + | `Pack -> "pack" + | `Pack_layered -> "pack-layered" + | `Pack_mem -> "pack-mem") + | `Replay_path_conversion -> ( + match s.config.setup with + | `Play _ -> "n/a" + | `Replay s -> ( + match s.path_conversion with + | `None -> "none" + | `V1 -> "v1" + | `V0_and_v1 -> "v0+v1" + | `V0 -> "v0")) + + let box_of_summaries_config summary_names (summaries : summary list) = + let summary_name_length = List.length summary_names in + let row0 = [ "" :: summary_names ] in + let separator_row = + [ List.init (summary_name_length + 1) (Fun.const "--") ] + in + let rows = + List.map + (fun e -> + let n = name_of_summary_config_entry e in + let l = List.map (fun s -> cell_of_summary_config s e) summaries in + n :: l) + summary_config_entries + in + row0 @ separator_row @ rows |> Pb.matrix_to_text +end + +(** Highlights *) +module Table1 = struct + let rows_of_summaries summaries = + let cpu_time_elapsed = List.map (fun s -> s.elapsed_cpu) summaries in + let wall_time_elapsed = List.map (fun s -> s.elapsed_wall) summaries in + let add_per_sec = + List.map + (fun s -> + fst Summary.(Span.Map.find `Add s.span).cumu_count.max_value + /. s.elapsed_cpu) + summaries + in + let tail_latency = + List.map + (fun s -> fst Summary.(Span.Map.find `Commit s.span).duration.max_value) + summaries + in + let tx_per_sec = + (* TODO: When replaying on a middle section of the chain, set + [~first_block_idx] *) + List.map + (fun s -> + (Utils.approx_transaction_count_of_block_count s.block_count + |> float_of_int) + /. s.elapsed_cpu) + summaries + in + let tz_ops_per_sec = + (* TODO: When replaying on a middle section of the chain, set + [~first_block_idx] *) + List.map + (fun s -> + (Utils.approx_operation_count_of_block_count s.block_count + |> float_of_int) + /. s.elapsed_cpu) + summaries + in + let bytes = + List.map (fun s -> s.index.bytes_both.value_after_commit.diff) summaries + in + let read_bytes = + List.map (fun s -> s.index.bytes_read.value_after_commit.diff) summaries + in + let written_bytes = + List.map + (fun s -> s.index.bytes_written.value_after_commit.diff) + summaries + in + let throughput = + List.map + (fun s -> s.index.bytes_both.value_after_commit.diff /. s.elapsed_cpu) + summaries + in + let read_throughput = + List.map + (fun s -> s.index.bytes_read.value_after_commit.diff /. s.elapsed_cpu) + summaries + in + let write_throughput = + List.map + (fun s -> + s.index.bytes_written.value_after_commit.diff /. s.elapsed_cpu) + summaries + in + let iops = + List.map + (fun s -> s.index.nb_both.value_after_commit.diff /. s.elapsed_cpu) + summaries + in + let read_iops = + List.map + (fun s -> s.index.nb_reads.value_after_commit.diff /. s.elapsed_cpu) + summaries + in + let write_iops = + List.map + (fun s -> s.index.nb_writes.value_after_commit.diff /. s.elapsed_cpu) + summaries + in + let max_ram = + List.map + (fun s -> List.fold_left max 0. s.gc.major_heap_top_bytes) + summaries + in + let mean_cpu_usage = + List.map (fun s -> s.elapsed_cpu /. s.elapsed_wall) summaries + in + [ + `Section "-- main metrics --"; + `Data (`SM, "CPU time elapsed", cpu_time_elapsed); + `Data (`SM, "Wall time elapsed", wall_time_elapsed); + `Data (`R3, "TZ-transactions per sec", tx_per_sec); + `Data (`R3, "TZ-operations per sec", tz_ops_per_sec); + `Data (`R3, "Context.set per sec", add_per_sec); + `Data (`S3, "tail latency (1)", tail_latency); + `Section ""; + `Section "-- resource usage --"; + `Section "disk IO (total)"; + `Data (`Ri, " IOPS (op/sec)", iops); + `Data (`RM, " throughput (bytes/sec)", throughput); + `Data (`RG, " total (bytes)", bytes); + `Section "disk IO (read)"; + `Data (`Ri, " IOPS (op/sec)", read_iops); + `Data (`RM, " throughput (bytes/sec)", read_throughput); + `Data (`RG, " total (bytes)", read_bytes); + `Section "disk IO (write)"; + `Data (`Ri, " IOPS (op/sec)", write_iops); + `Data (`RM, " throughput (bytes/sec)", write_throughput); + `Data (`RG, " total (bytes)", written_bytes); + `Section ""; + `Data (`RG, "max memory usage", max_ram); + `Data (`P, "mean CPU usage", mean_cpu_usage); + ] + + type data_row = [ `Data of scalar_format_fixed * string * float list ] + type section_row = [ `Section of string ] + + let cells_of_data_row (`Data (scalar_format, row_name, scalars) : data_row) = + let v0 = List.hd scalars in + let pp_cell i v = + let percent ppf = + if i = 0 then () + else if scalar_format = `P then Format.fprintf ppf " " + else Format.fprintf ppf " %a" Utils.pp_percent (v /. v0) + in + Fmt.str "%a%t" pp_scalar_fixed (scalar_format, v) percent + in + + Pb.text row_name + :: (List.mapi pp_cell scalars + |> List.map Pb.text + |> List.map (Pb.align ~h:`Right ~v:`Top)) + + let cells_of_section_row col_count (`Section name : section_row) = + Pb.text name + :: (List.init (col_count - 1) (Fun.const "") |> List.map Pb.text) + + let cells_of_row col_count = function + | `Data _ as row -> cells_of_data_row row + | `Section _ as row -> (cells_of_section_row col_count) row + + let matrix_of_rows col_count rows = List.map (cells_of_row col_count) rows +end + +module Table2 = struct + type variable = float * float * float * float + (** min, max, avg, avg per sec *) + + type summary_floor = + [ `Spacer + | `Data of + (scalar_format_fixed * scalar_format_fixed) + * string + * (string * variable) list ] + + let create_header_rows summaries = + let only_one_summary = List.length summaries = 1 in + [ + ("" :: (if only_one_summary then [] else [ "" ])) + @ [ "min per block"; "max per block"; "avg per block"; "avg per sec" ]; + ] + |> Pb.matrix_to_text + |> Pb.align_matrix `Center + + let floors_of_summaries : string list -> summary list -> summary_floor list = + fun summary_names summaries -> + let zip : (summary -> variable) -> (string * variable) list = + fun variable_of_summary -> + List.map2 + (fun sname s -> (sname, variable_of_summary s)) + summary_names summaries + in + let pb : ?f:_ -> string -> (summary -> Summary.bag_stat) -> summary_floor = + fun ?(f = (`Ri, `R3)) stat_name lbs_of_summary -> + let variables = + zip (fun s -> + let vs = (lbs_of_summary s).diff_per_block in + ( fst vs.min_value, + fst vs.max_value, + vs.mean, + vs.mean *. float_of_int s.block_count /. s.elapsed_wall )) + in + `Data (f, stat_name, variables) + in + let span_occu_per_block : string -> Span.Key.t -> summary_floor = + fun name op -> + let variables = + let open Summary in + zip (fun s -> + let vs = Span.(Map.find op s.span).count in + ( fst vs.min_value, + fst vs.max_value, + vs.mean, + vs.mean *. float_of_int s.block_count /. s.elapsed_wall )) + in + `Data ((`Ri, `R3), name, variables) + in + [ + `Spacer; + span_occu_per_block "Add count" `Add; + span_occu_per_block "Remove count" `Remove; + span_occu_per_block "Find count" `Find; + span_occu_per_block "Mem count" `Mem; + span_occu_per_block "Mem_tree count" `Mem_tree; + span_occu_per_block "Copy count" `Copy; + span_occu_per_block "Commit count" `Commit; + `Spacer; + pb ~f:(`RM, `RM) "Disk bytes read" (fun s -> s.index.bytes_read); + pb ~f:(`RM, `RM) "Disk bytes written" (fun s -> s.index.bytes_written); + pb ~f:(`RM, `RM) "Disk bytes both" (fun s -> s.index.bytes_both); + `Spacer; + pb "Disk reads" (fun s -> s.index.nb_reads); + pb "Disk writes" (fun s -> s.index.nb_writes); + pb "Disk both" (fun s -> s.index.nb_both); + `Spacer; + pb "pack.finds" (fun s -> s.pack.finds.total); + pb "pack.finds.from_staging" (fun s -> s.pack.finds.from_staging); + pb "pack.finds.from_lru" (fun s -> s.pack.finds.from_lru); + pb "pack.finds.from_pack_direct" (fun s -> s.pack.finds.from_pack_direct); + pb "pack.finds.from_pack_indexed" (fun s -> + s.pack.finds.from_pack_indexed); + pb "pack.finds.missing" (fun s -> s.pack.finds.missing); + pb "pack.finds.cache_miss" (fun s -> s.pack.finds.cache_miss); + pb "pack.appended_hashes" (fun s -> s.pack.appended_hashes); + pb "pack.appended_offsets" (fun s -> s.pack.appended_offsets); + pb "pack.inode_add" (fun s -> s.pack.inode_add); + pb "pack.inode_remove" (fun s -> s.pack.inode_remove); + pb "pack.inode_of_seq" (fun s -> s.pack.inode_of_seq); + pb "pack.inode_of_raw" (fun s -> s.pack.inode_of_raw); + pb "pack.inode_rec_add" (fun s -> s.pack.inode_rec_add); + pb "pack.inode_rec_remove" (fun s -> s.pack.inode_rec_remove); + pb "pack.inode_to_binv" (fun s -> s.pack.inode_to_binv); + pb "pack.inode_decode_bin" (fun s -> s.pack.inode_decode_bin); + pb "pack.inode_encode_bin" (fun s -> s.pack.inode_encode_bin); + `Spacer; + pb "tree.contents_hash" (fun s -> s.tree.contents_hash); + pb "tree.contents_find" (fun s -> s.tree.contents_find); + pb "tree.contents_add" (fun s -> s.tree.contents_add); + pb "tree.node_hash" (fun s -> s.tree.node_hash); + pb "tree.node_mem" (fun s -> s.tree.node_mem); + pb "tree.node_add" (fun s -> s.tree.node_add); + pb "tree.node_find" (fun s -> s.tree.node_find); + pb "tree.node_val_v" (fun s -> s.tree.node_val_v); + pb "tree.node_val_find" (fun s -> s.tree.node_val_find); + pb "tree.node_val_list" (fun s -> s.tree.node_val_list); + `Spacer; + pb ~f:(`RM, `Ri) "index.cumu_data_bytes" (fun s -> + s.index.cumu_data_bytes); + `Spacer; + pb ~f:(`RM, `RM) "gc.minor_words allocated" (fun s -> s.gc.minor_words); + pb ~f:(`RM, `RM) "gc.major_words allocated" (fun s -> s.gc.major_words); + pb "gc.minor_collections" (fun s -> s.gc.minor_collections); + pb "gc.major_collections" (fun s -> s.gc.major_collections); + ] + + let matrix_of_data_floor + (`Data + ((scalar_format_a, scalar_format_b), floor_name, names_and_variables)) = + let only_one_summary = List.length names_and_variables = 1 in + let _, variables = List.split names_and_variables in + let min0, max0, avg0, avg_ps0 = List.hd variables in + + let box_of_scalar scalar_format row_idx v0 v = + let ratio = v /. v0 in + let show_percent = + if only_one_summary then + (* Percents are only needed for comparisons between summaries. *) + `No + else if Float.is_finite ratio = false then + (* Nan and infinite percents are ugly. *) + `Shadow + else if row_idx = 0 then + (* The first row of a floor is always 100%, it is prettier without + displaying it. *) + `Shadow + else `Yes + in + let pp_percent ppf = + match show_percent with + | `Yes -> Format.fprintf ppf " %a" Utils.pp_percent ratio + | `Shadow -> Format.fprintf ppf " " + | `No -> () + in + let pp_scalar ppf = pp_scalar_fixed ppf (scalar_format, v) in + Fmt.str "%t%t" pp_scalar pp_percent + |> Pb.text + |> Pb.align ~h:`Right ~v:`Top + in + let rows = + List.mapi + (fun row_idx (summary_name, variable) -> + let a = Pb.text (if row_idx = 0 then floor_name else "") in + let b = if only_one_summary then [] else [ Pb.text summary_name ] in + let c = + let min, max, avg, avg_ps = variable in + [ + box_of_scalar scalar_format_a row_idx min0 min; + box_of_scalar scalar_format_a row_idx max0 max; + box_of_scalar scalar_format_b row_idx avg0 avg; + box_of_scalar scalar_format_b row_idx avg_ps0 avg_ps; + ] + in + (a :: b) @ c) + names_and_variables + in + rows + + let matrix_of_floor col_count = function + | `Spacer -> [ List.init col_count (Fun.const "") ] |> Pb.matrix_to_text + | `Data _ as floor -> matrix_of_data_floor floor +end + +module Table3 = struct + type variable = float * float * float + (** min, max, avg *) + + type summary_floor = + [ `Spacer + | `Data of + (scalar_format_fixed * scalar_format_fixed) + * string + * (string * variable) list ] + + let create_header_rows summaries = + let only_one_summary = List.length summaries = 1 in + [ + ("" :: (if only_one_summary then [] else [ "" ])) + @ [ "min"; "max"; "avg" ]; + ] + |> Pb.matrix_to_text + |> Pb.align_matrix `Center + + let floors_of_summaries : string list -> summary list -> summary_floor list = + fun summary_names summaries -> + let zip : (summary -> variable) -> (string * variable) list = + fun variable_of_summary -> + List.map2 + (fun sname s -> (sname, variable_of_summary s)) + summary_names summaries + in + + let v : ?f:_ -> string -> (summary -> Summary.bag_stat) -> summary_floor = + fun ?(f = (`RM, `RM)) stat_name lbs_of_summary -> + let variables = + zip (fun s -> + let vs = (lbs_of_summary s).value_after_commit in + (fst vs.min_value, fst vs.max_value, vs.mean)) + in + `Data (f, stat_name, variables) + in + let cpu_usage_variables = + zip (fun s -> + let vs = s.cpu_usage in + (fst vs.min_value, fst vs.max_value, vs.mean)) + in + let span_durations : ?f:_ -> string -> Span.Key.t -> summary_floor = + fun ?(f = (`Sm, `Su)) name op -> + let variables = + let open Summary in + zip (fun s -> + let vs = Span.(Map.find op s.span).duration in + (fst vs.min_value, fst vs.max_value, vs.mean)) + in + `Data (f, name, variables) + in + [ + `Spacer; + span_durations ~f:(`S3, `Sm) "Block duration (s)" `Block; + span_durations ~f:(`S3, `Sm) "Buildup duration (s)" `Buildup; + span_durations ~f:(`S3, `Sm) "Commit duration (s)" `Commit; + `Spacer; + span_durations "Add duration (s)" `Add; + span_durations "Remove duration (s)" `Remove; + span_durations "Find duration (s)" `Find; + span_durations "Mem duration (s)" `Mem; + span_durations "Mem_tree duration (s)" `Mem_tree; + span_durations "Copy duration (s)" `Copy; + span_durations ~f:(`S3, `Sm) "Unseen duration (s)" `Unseen; + `Spacer; + v "Major heap bytes after commit" (fun s -> s.gc.major_heap_bytes); + `Spacer; + `Data ((`P, `P), "CPU Usage", cpu_usage_variables); + ] + + let matrix_of_data_floor + (`Data + ((scalar_format_a, scalar_format_b), floor_name, names_and_variables)) = + let only_one_summary = List.length names_and_variables = 1 in + let _, variables = List.split names_and_variables in + let min0, max0, avg0 = List.hd variables in + + let box_of_scalar scalar_format row_idx v0 v = + let ratio = v /. v0 in + let show_percent = + if only_one_summary then + (* Percents are only needed for comparisons between summaries. *) + `No + else if Float.is_finite ratio = false then + (* Nan and infinite percents are ugly. *) + `Shadow + else if row_idx = 0 then + (* The first row of a floor is always 100%, it is prettier without + displaying it. *) + `Shadow + else if scalar_format = `P then `Shadow + else `Yes + in + let pp_percent ppf = + match show_percent with + | `Yes -> Format.fprintf ppf " %a" Utils.pp_percent ratio + | `Shadow -> Format.fprintf ppf " " + | `No -> () + in + let pp_scalar ppf = pp_scalar_fixed ppf (scalar_format, v) in + + Fmt.str "%t%t" pp_scalar pp_percent + |> Pb.text + |> Pb.align ~h:`Right ~v:`Top + in + let rows = + List.mapi + (fun row_idx (summary_name, variable) -> + let a = Pb.text (if row_idx = 0 then floor_name else "") in + let b = if only_one_summary then [] else [ Pb.text summary_name ] in + let c = + let min, max, avg = variable in + [ + box_of_scalar scalar_format_b row_idx min0 min; + box_of_scalar scalar_format_a row_idx max0 max; + box_of_scalar scalar_format_b row_idx avg0 avg; + ] + in + (a :: b) @ c) + names_and_variables + in + rows + + let matrix_of_floor col_count = function + | `Spacer -> [ List.init col_count (Fun.const "") ] |> Pb.matrix_to_text + | `Data _ as floor -> matrix_of_data_floor floor +end + +(** Curves *) +module Table4 = struct + type scalar_format_auto = [ `R | `S ] + (** Real / Seconds *) + + type scalar_format = [ scalar_format_auto | scalar_format_fixed ] + + type summary_floor = + [ `Spacer | `Data of scalar_format * string * (string * curve) list ] + (** A [summary_floor] of tag [`Data] contains all the data necessary in order + to print a bunch of rows, 1 per summary, all displaying the same summary + entry. *) + + let sum_curves curves = + curves + |> Pb.transpose_matrix + |> List.map + (List.fold_left + (fun acc v -> if Float.is_nan v then acc else acc +. v) + 0.) + + let div_curves a b = List.map2 ( /. ) a b + let mul_curves a b = List.map2 ( *. ) a b + let mul_curve_scalar a v = List.map (( *. ) v) a + + let create_header_rows sample_count summaries = + let only_one_summary = List.length summaries = 1 in + let s = List.hd summaries in + let played_count_curve = + List.init s.curves_sample_count (fun i -> + float_of_int i + /. float_of_int (s.curves_sample_count - 1) + *. float_of_int s.block_count) + in + let played_count_curve = + Utils.Resample.resample_vector `Next_neighbor played_count_curve + sample_count + |> Array.of_list + in + let header_cells_per_col_idx col_idx = + let played_count = played_count_curve.(col_idx) in + let progress_blocks = played_count /. float_of_int s.block_count in + let h0 = + if progress_blocks = 0. then "0 (before)" + else if progress_blocks = 1. then + Printf.sprintf "%.0f (end)" played_count + else if Float.is_integer played_count then + Printf.sprintf "%.0f" played_count + else Printf.sprintf "%.1f" played_count + in + let h1 = Printf.sprintf "%.0f%%" (progress_blocks *. 100.) in + [ h0; h1 ] + in + let col_a = + [ [ "Block played count *C"; "Blocks progress *C" ] ] |> Pb.matrix_to_text + in + let col_b = + (if only_one_summary then [] else [ [ ""; "" ] ]) + |> Pb.matrix_to_text + |> Pb.align_matrix `Center + in + let cols_c = + List.init sample_count header_cells_per_col_idx + |> Pb.matrix_to_text + |> Pb.align_matrix `Center + in + col_a @ col_b @ cols_c |> Pb.transpose_matrix + + let floors_of_summaries : string list -> summary list -> summary_floor list = + fun summary_names summaries -> + (* Step 1/3 - Prepare the "/data/..." directories floors *) + let floor_per_node : summary_floor list = + List.map + (fun key -> + let path = List.assoc key Def.path_per_watched_node in + let name = Printf.sprintf "%s *S" path in + let curves = + List.map + (fun s -> + (Summary.Watched_node.Map.find key s.store.watched_nodes).value + .evolution) + summaries + in + let l = List.combine summary_names curves in + `Data (`R, name, l)) + Def.watched_nodes + in + + (* Step 2/3 - Prepare the functions to build all the simple floors *) + let zip : (summary -> curve) -> (string * curve) list = + fun curve_of_summary -> + List.map2 + (fun sname s -> (sname, curve_of_summary s)) + summary_names summaries + in + let zip_per_block_to_per_sec : (summary -> curve) -> (string * curve) list = + let sec_per_block = + List.map + (fun s -> Summary.(Span.Map.find `Block s.span).duration.evolution) + summaries + in + fun curve_of_summary -> + List.map2 + (fun (sname, sec_per_block) s -> + (sname, div_curves (curve_of_summary s) sec_per_block)) + (List.combine summary_names sec_per_block) + summaries + in + + let v : ?f:_ -> string -> (summary -> Summary.bag_stat) -> summary_floor = + fun ?(f = `R) stat_name lbs_of_summary -> + let curves = + zip (fun s -> (lbs_of_summary s).value_after_commit.evolution) + in + `Data (f, stat_name, curves) + in + let pb : ?f:_ -> string -> (summary -> Summary.bag_stat) -> summary_floor = + fun ?(f = `R) stat_name lbs_of_summary -> + let curves = zip (fun s -> (lbs_of_summary s).diff_per_block.evolution) in + `Data (f, stat_name, curves) + in + let ps : ?f:_ -> string -> (summary -> Summary.bag_stat) -> summary_floor = + fun ?(f = `R) stat_name lbs_of_summary -> + let curves = + zip_per_block_to_per_sec (fun s -> + (lbs_of_summary s).diff_per_block.evolution) + in + `Data (f, stat_name, curves) + in + + let span_occu_count : string -> Span.Key.t -> summary_floor = + fun name op -> + let curves = + zip (fun s -> Summary.(Span.Map.find op s.span).count.evolution) + in + `Data (`R3, name, curves) + in + let span_duration : _ -> string -> Span.Key.t -> summary_floor = + fun f name op -> + let curves = + zip (fun s -> Summary.(Span.Map.find op s.span).duration.evolution) + in + `Data (f, name, curves) + in + let span_occu_every_sec : string -> Span.Key.t -> summary_floor = + fun name op -> + let curves = + zip_per_block_to_per_sec (fun s -> + Summary.(Span.Map.find op s.span).count.evolution) + in + `Data (`R3, name, curves) + in + + let all_ops_cumu_count = + zip (fun s -> + Summary.Span.Key.((all_atoms_seen :> t list)) + |> List.map (fun op -> + Summary.(Span.Map.find op s.span).cumu_count.evolution) + |> sum_curves) + in + + let tz_tx_count = + (* TODO: When replaying on a middle section of the chain, set + [~first_block_idx] *) + zip (fun s -> + let played_count_curve = + List.init s.curves_sample_count (fun i -> + float_of_int i + /. float_of_int (s.curves_sample_count - 1) + *. float_of_int s.block_count) + |> List.map (fun v -> + Utils.approx_transaction_count_of_block_count + (int_of_float v) + |> float_of_int) + in + played_count_curve) + in + let tz_ops_count = + (* TODO: When replaying on a middle section of the chain, set + [~first_block_idx] *) + zip (fun s -> + let played_count_curve = + List.init s.curves_sample_count (fun i -> + float_of_int i + /. float_of_int (s.curves_sample_count - 1) + *. float_of_int s.block_count) + |> List.map (fun v -> + Utils.approx_operation_count_of_block_count (int_of_float v) + |> float_of_int) + in + played_count_curve) + in + + (* Step 3/3 - Build the final list of floors *) + [ + `Spacer; + `Data + (`S, "Wall time elapsed *C", zip (fun s -> s.elapsed_wall_over_blocks)); + `Data (`S, "CPU time elapsed *C", zip (fun s -> s.elapsed_cpu_over_blocks)); + `Data (`P, "CPU Usage *LA", zip (fun s -> s.cpu_usage.evolution)); + (* ops counts *) + `Spacer; + `Data (`R, "Approx. TZ-transaction count *C", tz_tx_count); + `Data (`R, "Approx. TZ-operations count *C", tz_ops_count); + `Data (`R, "Op count *C", all_ops_cumu_count); + (* per sec *) + `Spacer; + span_occu_every_sec "Commit per sec *LA *N" `Commit; + span_occu_every_sec "Add per sec *LA *N" `Add; + span_occu_every_sec "Remove per sec *LA *N" `Remove; + span_occu_every_sec "Find per sec *LA *N" `Find; + span_occu_every_sec "Mem per sec *LA *N" `Mem; + span_occu_every_sec "Mem_tree per sec *LA *N" `Mem_tree; + span_occu_every_sec "Copy per sec *LA *N" `Copy; + (* per block *) + `Spacer; + span_occu_count "Add count per block *LA" `Add; + span_occu_count "Remove count per block *LA" `Remove; + span_occu_count "Find count per block *LA" `Find; + span_occu_count "Mem count per block *LA" `Mem; + span_occu_count "Mem_tree count per block *LA" `Mem_tree; + span_occu_count "Copy count per block *LA" `Copy; + (* duration *) + `Spacer; + span_duration `Sm "Block duration *LA" `Block; + span_duration `Sm "Buildup duration *LA" `Buildup; + span_duration `Sm "Commit duration *LA" `Commit; + `Spacer; + (* duration *) + span_duration `Su "Add duration *LA" `Add; + span_duration `Su "Remove duration *LA" `Remove; + span_duration `Su "Find duration *LA" `Find; + span_duration `Su "Mem duration *LA" `Mem; + span_duration `Su "Mem_tree duration *LA" `Mem_tree; + span_duration `Su "Copy duration *LA" `Copy; + span_duration `Su "Checkout duration *LA" `Checkout; + (* derived from bag_of_stat *) + `Spacer; + v "Disk bytes read *C" (fun s -> s.index.bytes_read); + v "Disk bytes written *C" (fun s -> s.index.bytes_written); + v "Disk bytes both *C" (fun s -> s.index.bytes_both); + pb ~f:`Ri "Disk bytes read per block *LA" (fun s -> s.index.bytes_read); + pb ~f:`Ri "Disk bytes written per block *LA" (fun s -> + s.index.bytes_written); + pb ~f:`Ri "Disk bytes both per block *LA" (fun s -> s.index.bytes_both); + ps ~f:`RM "Disk bytes read per sec *LA *N" (fun s -> + s.index.bytes_read); + ps ~f:`RM "Disk bytes written per sec *LA *N" (fun s -> + s.index.bytes_written); + ps ~f:`RM "Disk bytes both per sec *LA *N" (fun s -> + s.index.bytes_both); + `Spacer; + v "Disk read count *C" (fun s -> s.index.nb_reads); + v "Disk write count *C" (fun s -> s.index.nb_writes); + v "Disk both count *C" (fun s -> s.index.nb_both); + pb ~f:`R3 "Disk read count per block *LA" (fun s -> s.index.nb_reads); + pb ~f:`R3 "Disk write count per block *LA" (fun s -> s.index.nb_writes); + pb ~f:`R3 "Disk both count per block *LA" (fun s -> s.index.nb_both); + ps ~f:`Ri "Disk read count per sec *LA *N" (fun s -> s.index.nb_reads); + ps ~f:`Ri "Disk write count per sec *LA *N" (fun s -> s.index.nb_writes); + ps ~f:`Ri "Disk both count per sec *LA *N" (fun s -> s.index.nb_both); + `Spacer; + pb "pack.appended_hashes per block *LA" (fun s -> s.pack.appended_hashes); + pb "pack.appended_offsets per block *LA" (fun s -> + s.pack.appended_offsets); + pb "pack.finds per block *LA" (fun s -> s.pack.finds.total); + pb "pack.finds.from_staging per block *LA" (fun s -> + s.pack.finds.from_staging); + pb "pack.finds.from_lru per block *LA" (fun s -> s.pack.finds.from_lru); + pb "pack.finds.from_pack_direct per block *LA" (fun s -> + s.pack.finds.from_pack_direct); + pb "pack.finds.from_pack_indexed per block *LA" (fun s -> + s.pack.finds.from_pack_indexed); + pb "pack.finds.missing per block *LA" (fun s -> s.pack.finds.missing); + pb "pack.finds.cache_miss per block *LA" (fun s -> + s.pack.finds.cache_miss); + pb "pack.inode_add per block *LA" (fun s -> s.pack.inode_add); + pb "pack.inode_remove per block *LA" (fun s -> s.pack.inode_remove); + pb "pack.inode_of_seq per block *LA" (fun s -> s.pack.inode_of_seq); + pb "pack.inode_of_raw per block *LA" (fun s -> s.pack.inode_of_raw); + pb "pack.inode_rec_add per block *LA" (fun s -> s.pack.inode_rec_add); + pb "pack.inode_rec_remove per block *LA" (fun s -> + s.pack.inode_rec_remove); + pb "pack.inode_to_binv per block *LA" (fun s -> s.pack.inode_to_binv); + pb "pack.inode_decode_bin per block *LA" (fun s -> + s.pack.inode_decode_bin); + pb "pack.inode_encode_bin per block *LA" (fun s -> + s.pack.inode_encode_bin); + `Spacer; + pb "tree.contents_hash per block *LA" (fun s -> s.tree.contents_hash); + pb "tree.contents_find per block *LA" (fun s -> s.tree.contents_find); + pb "tree.contents_add per block *LA" (fun s -> s.tree.contents_add); + pb "tree.node_hash per block *LA" (fun s -> s.tree.node_hash); + pb "tree.node_mem per block *LA" (fun s -> s.tree.node_mem); + pb "tree.node_add per block *LA" (fun s -> s.tree.node_add); + pb "tree.node_find per block *LA" (fun s -> s.tree.node_find); + pb "tree.node_val_v per block *LA" (fun s -> s.tree.node_val_v); + pb "tree.node_val_find per block *LA" (fun s -> s.tree.node_val_find); + pb "tree.node_val_list per block *LA" (fun s -> s.tree.node_val_list); + `Spacer; + v "index.nb_merge *C" (fun s -> s.index.nb_merge); + v "index.cumu_data_bytes *C" (fun s -> s.index.cumu_data_bytes); + pb "index.cumu_data_bytes per block *LA" (fun s -> + s.index.cumu_data_bytes); + `Spacer; + v "gc.minor_words allocated *C" (fun s -> s.gc.minor_words); + pb "gc.minor_words allocated per block *LA" (fun s -> s.gc.minor_words); + v "gc.promoted_words *C" (fun s -> s.gc.promoted_words); + v "gc.major_words allocated *C" (fun s -> s.gc.major_words); + pb "gc.major_words allocated per block *LA" (fun s -> s.gc.major_words); + v "gc.minor_collections *C" (fun s -> s.gc.minor_collections); + pb "gc.minor_collections per block *LA" (fun s -> s.gc.minor_collections); + v "gc.major_collections *C" (fun s -> s.gc.major_collections); + pb "gc.major_collections per block *LA" (fun s -> s.gc.major_collections); + v "gc.compactions *C" (fun s -> s.gc.compactions); + `Spacer; + `Data + ( `RM, + "gc.major heap bytes top *C", + zip (fun s -> s.gc.major_heap_top_bytes) ); + v ~f:`RM "gc.major heap bytes *LA" (fun s -> s.gc.major_heap_bytes); + `Spacer; + v "index_data bytes *S" (fun s -> s.disk.index_data); + pb "index_data bytes per block *LA" (fun s -> s.disk.index_data); + v "store_pack bytes *S" (fun s -> s.disk.store_pack); + pb "store_pack bytes per block *LA" (fun s -> s.disk.store_pack); + v "index_log bytes *S" (fun s -> s.disk.index_log); + v "index_log_async *S" (fun s -> s.disk.index_log_async); + v "store_dict bytes *S" (fun s -> s.disk.store_dict); + `Spacer; + ] + @ floor_per_node + + let resample_curves_of_floor sample_count = function + | `Data (a, b, names_and_curves) -> + let names, curves = List.split names_and_curves in + let curves = + List.map + (fun curve -> + Utils.Resample.resample_vector `Next_neighbor curve sample_count) + curves + in + `Data (a, b, List.combine names curves) + | `Spacer -> `Spacer + + let matrix_of_data_floor (`Data (scalar_format, floor_name, names_and_curves)) + = + let only_one_summary = List.length names_and_curves = 1 in + let _, curves = List.split names_and_curves in + let pp_real = Utils.create_pp_real (List.concat curves) in + let pp_seconds = Utils.create_pp_seconds (List.concat curves) in + let curve0 = List.hd curves in + let box_of_scalar row_idx col_idx (v0, v) = + let ratio = v /. v0 in + let show_percent = + if only_one_summary then + (* Percents are only needed for comparisons between summaries. *) + `No + else if col_idx = 0 then + (* The first columns is usually full of NaNs, showing percents there + is a waste of space. *) + `No + else if Float.is_finite ratio = false then + (* Nan and infinite percents are ugly. *) + `Shadow + else if row_idx = 0 then + (* The first row of a floor is always 100%, it is prettier without + displaying it. *) + `Shadow + else if scalar_format = `P then `Shadow + else `Yes + in + let pp_percent ppf = + match show_percent with + | `Yes -> Format.fprintf ppf " %a" Utils.pp_percent ratio + | `Shadow -> Format.fprintf ppf " " + | `No -> () + in + let pp_scalar ppf = + match scalar_format with + | `R -> Format.fprintf ppf "%a" pp_real v + | `S -> Format.fprintf ppf "%a" pp_seconds v + | #scalar_format_fixed as scalar_format -> + pp_scalar_fixed ppf (scalar_format, v) + in + Fmt.str "%t%t" pp_scalar pp_percent + |> Pb.text + |> Pb.align ~h:`Right ~v:`Top + in + let rows = + List.mapi + (fun row_idx (summary_name, curve) -> + let a = Pb.text (if row_idx = 0 then floor_name else "") in + let b = if only_one_summary then [] else [ Pb.text summary_name ] in + let c = + List.mapi (box_of_scalar row_idx) (List.combine curve0 curve) + in + (a :: b) @ c) + names_and_curves + in + rows + + let matrix_of_floor col_count = function + | `Spacer -> [ List.init col_count (Fun.const "") ] |> Pb.matrix_to_text + | `Data _ as floor -> matrix_of_data_floor floor +end + +let unsafe_pp sample_count ppf summary_names (summaries : Summary.t list) = + let block_count = + let l = List.map (fun s -> s.block_count) summaries in + let v = List.hd l in + if List.exists (fun v' -> v' <> v) l then + failwith "Can't pp together summaries with a different `block_count`"; + v + in + let moving_average_half_life_ratio = + let l = List.map (fun s -> s.moving_average_half_life_ratio) summaries in + let v = List.hd l in + if List.exists (fun v' -> v' <> v) l then + failwith + "Can't pp together summaries with a different \ + `moving_average_half_life_ratio`"; + v + in + let table0 = + Table0.box_of_summaries_config summary_names summaries + |> Pb.matrix_with_column_spacers + |> Pb.grid_l ~bars:false + |> PrintBox_text.to_string + in + let table1 = + let summary_length = List.length summaries in + let header_rows = + [ "" :: summary_names ] |> Pb.matrix_to_text |> Pb.align_matrix `Center + in + let col_count = summary_length + 1 in + let separator = + ([ List.init (summary_length + 1) (Fun.const "--") ] : string list list) + in + let separator_row = Pb.matrix_to_text separator in + let body_rows = + Table1.rows_of_summaries summaries |> Table1.matrix_of_rows col_count + in + header_rows @ separator_row @ body_rows + |> Pb.matrix_with_column_spacers + |> Pb.grid_l ~bars:false + |> PrintBox_text.to_string + in + let table2 = + let header_rows = Table2.create_header_rows summaries in + let body_rows = + let col_count = 4 + 1 + if List.length summaries = 1 then 0 else 1 in + Table2.floors_of_summaries summary_names summaries + |> List.map (Table2.matrix_of_floor col_count) + |> List.concat + in + header_rows @ body_rows + |> Pb.matrix_with_column_spacers + |> Pb.grid_l ~bars:false + |> PrintBox_text.to_string + in + let table3 = + let header_rows = Table3.create_header_rows summaries in + let body_rows = + let col_count = 4 + 1 + if List.length summaries = 1 then 0 else 1 in + Table3.floors_of_summaries summary_names summaries + |> List.map (Table3.matrix_of_floor col_count) + |> List.concat + in + header_rows @ body_rows + |> Pb.matrix_with_column_spacers + |> Pb.grid_l ~bars:false + |> PrintBox_text.to_string + in + let table4 = + let header_rows = Table4.create_header_rows sample_count summaries in + let body_rows = + let col_count = + sample_count + 1 + if List.length summaries = 1 then 0 else 1 + in + Table4.floors_of_summaries summary_names summaries + |> List.map (Table4.resample_curves_of_floor sample_count) + |> List.map (Table4.matrix_of_floor col_count) + |> List.concat + in + header_rows @ body_rows + |> Pb.matrix_with_column_spacers + |> Pb.grid_l ~bars:false + |> PrintBox_text.to_string + in + fprintf_result ppf table0 table1 table2 table3 table4 + (moving_average_half_life_ratio *. float_of_int (block_count + 1)) + +let pp sample_count ppf (summary_names, summaries) = + if List.length summaries = 0 then () + else unsafe_pp sample_count ppf summary_names summaries diff --git a/vendors/irmin/bench/irmin-pack/trace_stat_summary_utils.ml b/vendors/irmin/bench/irmin-pack/trace_stat_summary_utils.ml new file mode 100644 index 0000000000000000000000000000000000000000..e35846aed403413dc757c7c6db1f7cdd2b343d3e --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_stat_summary_utils.ml @@ -0,0 +1,636 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type histo = (float * int) list [@@deriving repr] +type curve = float list [@@deriving repr] + +let snap_to_integer ~significant_digits v = + if significant_digits < 0 then + invalid_arg "significant_digits should be greater or equal to zero."; + if not @@ Float.is_finite v then v + else if Float.is_integer v then v + else + (* This scope is about choosing between [v] and [Float.round v]. *) + let significant_digits = float_of_int significant_digits in + let v' = Float.round v in + if v' = 0. then (* Do not snap numbers close to 0. *) + v + else + let round_distance = Float.abs (v -. v') in + assert (round_distance <= 0.5); + (* The smaller [round_distance], the greater [significant_digits']. *) + let significant_digits' = -.Float.log10 round_distance in + assert (significant_digits' > 0.); + if significant_digits' >= significant_digits then v' else v + +let pp_six_digits_with_spacer ppf v = + let s = Printf.sprintf "%.6f" v in + let len = String.length s in + let a = String.sub s 0 (len - 3) in + let b = String.sub s (len - 3) 3 in + Format.fprintf ppf "%s_%s" a b + +let create_pp_real ?(significant_digits = 7) examples = + let examples = List.map (snap_to_integer ~significant_digits) examples in + let all_integer = + List.for_all + (fun v -> Float.is_integer v || not (Float.is_finite v)) + examples + in + let absmax = + List.fold_left + (fun acc v -> + if not @@ Float.is_finite acc then v + else if not @@ Float.is_finite v then acc + else Float.abs v |> max acc) + Float.neg_infinity examples + in + let finite_pp = + if absmax /. 1e12 >= 10. then fun ppf v -> + Format.fprintf ppf "%.3f T" (v /. 1e12) + else if absmax /. 1e9 >= 10. then fun ppf v -> + Format.fprintf ppf "%.3f G" (v /. 1e9) + else if absmax /. 1e6 >= 10. then fun ppf v -> + Format.fprintf ppf "%.3f M" (v /. 1e6) + else if absmax /. 1e3 >= 10. then fun ppf v -> + Format.fprintf ppf "%#d" (Float.round v |> int_of_float) + else if all_integer then fun ppf v -> + Format.fprintf ppf "%#d" (Float.round v |> int_of_float) + else if absmax /. 1. >= 10. then fun ppf v -> Format.fprintf ppf "%.3f" v + else if absmax /. 1e-3 >= 10. then pp_six_digits_with_spacer + else fun ppf v -> Format.fprintf ppf "%.3e" v + in + fun ppf v -> + if Float.is_nan v then Format.fprintf ppf "n/a" + else if Float.is_infinite v then Format.fprintf ppf "%f" v + else finite_pp ppf v + +let create_pp_seconds examples = + let absmax = + List.fold_left + (fun acc v -> + if not @@ Float.is_finite acc then v + else if not @@ Float.is_finite v then acc + else Float.abs v |> max acc) + Float.neg_infinity examples + in + let finite_pp = + if absmax >= 60. then fun ppf v -> Mtime.Span.pp_float_s ppf v + else if absmax < 100. *. 1e-12 then fun ppf v -> + Format.fprintf ppf "%.3e s" v + else if absmax < 100. *. 1e-9 then fun ppf v -> + Format.fprintf ppf "%.3f ns" (v *. 1e9) + else if absmax < 100. *. 1e-6 then fun ppf v -> + Format.fprintf ppf "%.3f \xc2\xb5s" (v *. 1e6) + else if absmax < 100. *. 1e-3 then fun ppf v -> + Format.fprintf ppf "%.3f ms" (v *. 1e3) + else fun ppf v -> Format.fprintf ppf "%.3f s" v + in + fun ppf v -> + if Float.is_nan v then Format.fprintf ppf "n/a" + else if Float.is_infinite v then Format.fprintf ppf "%f" v + else finite_pp ppf v + +let pp_percent ppf v = + if not @@ Float.is_finite v then Format.fprintf ppf "%4f" v + else if v = 0. then Format.fprintf ppf " 0%%" + else if v < 10. /. 100. then Format.fprintf ppf "%3.1f%%" (v *. 100.) + else if v < 1000. /. 100. then Format.fprintf ppf "%3.0f%%" (v *. 100.) + else if v < 1000. then Format.fprintf ppf "%3.0fx" v + else if v < 9.5e9 then ( + let long_repr = Printf.sprintf "%.0e" v in + assert (String.length long_repr = 5); + Format.fprintf ppf "%ce%cx" long_repr.[0] long_repr.[4]) + else Format.fprintf ppf "++++" + +let weekly_stats = Tezos_history_metrics.weekly_stats + +let approx_value_count_of_block_count value_of_row ?(first_block_idx = 0) + wished_block_count = + let end_block_idx = first_block_idx + wished_block_count in + let blocks_of_row (_, _, _, v) = v in + let fold (week_block0_idx, acc_value, acc_blocks) row = + let week_blocks = blocks_of_row row in + let week_value = value_of_row row in + assert (acc_blocks <= wished_block_count); + let nextweek_block0_idx = week_block0_idx + week_blocks in + let kept_block_count = + let left = + if first_block_idx >= nextweek_block0_idx then `After + else if first_block_idx <= week_block0_idx then `Before + else `Inside + in + let right = + if end_block_idx >= nextweek_block0_idx then `After + else if end_block_idx <= week_block0_idx then `Before + else `Inside + in + match (left, right) with + | `After, `After -> 0 + | `Before, `Before -> 0 + | `Before, `After -> week_blocks + | `Inside, `After -> first_block_idx - week_block0_idx + | `Inside, `Inside -> end_block_idx - first_block_idx + | `Before, `Inside -> wished_block_count - acc_blocks + | `Inside, `Before -> assert false + | `After, (`Before | `Inside) -> assert false + in + assert (kept_block_count >= 0); + assert (kept_block_count <= week_blocks); + let kept_tx_count = + let f = float_of_int in + f week_value /. f week_blocks *. f kept_block_count + |> Float.round + |> int_of_float + in + assert (kept_tx_count >= 0); + assert (kept_tx_count <= week_value); + let acc_blocks' = acc_blocks + kept_block_count in + let acc_value' = acc_value + kept_tx_count in + (nextweek_block0_idx, acc_value', acc_blocks') + in + let _, acc_value, acc_blocks = List.fold_left fold (0, 0, 0) weekly_stats in + assert (acc_blocks <= wished_block_count); + if acc_blocks = wished_block_count then acc_value + else + (* Extrapolate for the following weeks *) + let latest_weeks_tx_count, latest_weeks_block_count = + match List.rev weekly_stats with + | rowa :: rowb :: rowc :: _ -> + let value = + List.map value_of_row [ rowa; rowb; rowc ] |> List.fold_left ( + ) 0 + in + let blocks = + List.map blocks_of_row [ rowa; rowb; rowc ] + |> List.fold_left ( + ) 0 + in + (value, blocks) + | _ -> assert false + in + let missing_blocks = wished_block_count - acc_blocks in + let missing_value = + let f = float_of_int in + f latest_weeks_tx_count /. f latest_weeks_block_count *. f missing_blocks + |> Float.round + |> int_of_float + in + acc_value + missing_value + +let approx_transaction_count_of_block_count = + approx_value_count_of_block_count (fun (_, txs, _, _) -> txs) + +let approx_operation_count_of_block_count = + approx_value_count_of_block_count (fun (_, _, ops, _) -> ops) + +module Exponential_moving_average = struct + type t = { + momentum : float; + relevance_threshold : float; + opp_momentum : float; + hidden_state : float; + void_fraction : float; + } + + let create ?(relevance_threshold = 1.) momentum = + if momentum < 0. || momentum >= 1. then invalid_arg "Wrong momentum"; + if relevance_threshold < 0. || relevance_threshold > 1. then + invalid_arg "Wrong relevance_threshold"; + { + momentum; + relevance_threshold; + opp_momentum = 1. -. momentum; + hidden_state = 0.; + void_fraction = 1.; + } + + let from_half_life ?relevance_threshold hl = + if hl < 0. then invalid_arg "Wrong half life"; + create ?relevance_threshold (if hl = 0. then 0. else log 0.5 /. hl |> exp) + + let from_half_life_ratio ?relevance_threshold hl_ratio step_count = + if hl_ratio < 0. then invalid_arg "Wrong half life ratio"; + if step_count < 0. then invalid_arg "Wront step count"; + step_count *. hl_ratio |> from_half_life ?relevance_threshold + + let momentum ema = ema.momentum + let hidden_state ema = ema.hidden_state + let void_fraction ema = ema.void_fraction + let is_relevant ema = ema.void_fraction < ema.relevance_threshold + + let peek_exn ema = + if is_relevant ema then ema.hidden_state /. (1. -. ema.void_fraction) + else failwith "Can't peek an irrelevant EMA" + + let peek_or_nan ema = + if is_relevant ema then ema.hidden_state /. (1. -. ema.void_fraction) + else Float.nan + + let update ema sample = + let hidden_state = + (* The first term is the "forget" term, the second one is the "remember" + term. *) + (ema.momentum *. ema.hidden_state) +. (ema.opp_momentum *. sample) + in + let void_fraction = + (* [update] decreases the quantity of "void". *) + ema.momentum *. ema.void_fraction + in + { ema with hidden_state; void_fraction } + + let update_batch ema sample sample_size = + if sample_size <= 0. then invalid_arg "Wrong sample_size"; + let momentum = ema.momentum ** sample_size in + let opp_momentum = 1. -. momentum in + (* From this point, the code is identical to [update]. *) + let hidden_state = + (ema.hidden_state *. momentum) +. (sample *. opp_momentum) + in + let void_fraction = ema.void_fraction *. momentum in + { ema with hidden_state; void_fraction } + + (** [peek ema] is equal to [forget ema |> peek]. Modulo floating point + imprecisions and relevance changes. + + Proof: + + {v + v0 = hs0 / (1 - vf0) + v1 = hs1 / (1 - vf1) + hs1 = mom * hs0 + vf1 = mom * vf0 + (1 - mom) + hs0 / (1 - vf0) = hs1 / (1 - vf1) + hs0 / (1 - vf0) = (mom * hs0) / (1 - (mom * vf0 + (1 - mom))) + hs0 / (1 - vf0) = (mom * hs0) / (1 - (mom * vf0 + 1 - mom)) + hs0 / (1 - vf0) = (mom * hs0) / (1 + (-mom * vf0 - 1 + mom)) + hs0 / (1 - vf0) = (mom * hs0) / (1 - mom * vf0 - 1 + mom) + hs0 / (1 - vf0) = (mom * hs0) / ( -mom * vf0 + mom) + hs0 / (1 - vf0) = (hs0) / ( -1 * vf0 + 1) + hs0 / (1 - vf0) = hs0 / (1 - vf0) + v0 = v1 + v} *) + let forget ema = + let hidden_state = ema.momentum *. ema.hidden_state in + let void_fraction = + (* [forget] increases the quantity of "void". + + Where [update] does: [ema.m * ema.vf + ema.opp_m * 0], + [forget] does: [ema.m * ema.vf + ema.opp_m * 1]. *) + (ema.momentum *. ema.void_fraction) +. ema.opp_momentum + in + { ema with hidden_state; void_fraction } + + let forget_batch ema sample_size = + if sample_size <= 0. then invalid_arg "Wrong sample_size"; + let momentum = ema.momentum ** sample_size in + let opp_momentum = 1. -. momentum in + (* From this point, the code is identical to [forget]. *) + let hidden_state = ema.hidden_state *. momentum in + let void_fraction = (ema.void_fraction *. momentum) +. opp_momentum in + { ema with hidden_state; void_fraction } + + let map ?relevance_threshold momentum vec0 = + List.fold_left + (fun (ema, rev_result) v0 -> + let ema = update ema v0 in + let v1 = peek_or_nan ema in + (ema, v1 :: rev_result)) + (create ?relevance_threshold momentum, []) + vec0 + |> snd + |> List.rev +end + +module Resample = struct + let should_sample ~i0 ~len0 ~i1 ~len1 = + assert (len0 >= 2); + assert (len1 >= 2); + assert (i0 < len0); + assert (i0 >= 0); + assert (i1 >= 0); + if i1 >= len1 then `Out_of_bounds + else + let i0 = float_of_int i0 in + let len0 = float_of_int len0 in + let i1 = float_of_int i1 in + let len1 = float_of_int len1 in + let progress0_left = (i0 -. 1.) /. (len0 -. 1.) in + let progress0_right = i0 /. (len0 -. 1.) in + let progress1 = i1 /. (len1 -. 1.) in + if progress1 <= progress0_left then `Before + else if progress1 <= progress0_right then ( + let where_in_interval = + (progress1 -. progress0_left) /. (progress0_right -. progress0_left) + in + assert (where_in_interval > 0.); + assert (where_in_interval <= 1.); + `Inside where_in_interval) + else `After + + type acc = { + mode : [ `Interpolate | `Next_neighbor ]; + len0 : int; + len1 : int; + i0 : int; + i1 : int; + prev_v0 : float; + rev_samples : curve; + } + + let create_acc mode ~len0 ~len1 ~v00 = + let mode = (mode :> [ `Interpolate | `Next_neighbor ]) in + if len0 < 2 then invalid_arg "Can't resample curves below 2 points"; + if len1 < 2 then invalid_arg "Can't resample curves below 2 points"; + { mode; len0; len1; i0 = 1; i1 = 1; prev_v0 = v00; rev_samples = [ v00 ] } + + let accumulate ({ mode; len0; len1; i0; i1; prev_v0; rev_samples } as acc) v0 + = + assert (i0 >= 1); + assert (i1 >= 1); + if i0 >= len0 then failwith "Accumulate called to much"; + if i1 >= len1 then failwith "Accumulate called to much"; + let rec aux i1 rev_samples = + match should_sample ~len1 ~i0 ~len0 ~i1 with + | `Inside where_inside -> + if i1 = len1 - 1 then ( + assert (i0 = len0 - 1); + assert (where_inside = 1.)); + let v1 = + match mode with + | `Next_neighbor -> v0 + | `Interpolate when where_inside = 1. -> + (* Optimisation in case of nan *) + v0 + | `Interpolate -> prev_v0 +. (where_inside *. (v0 -. prev_v0)) + in + aux (i1 + 1) (v1 :: rev_samples) + | `After -> (i1, rev_samples) + | `Before -> assert false + | `Out_of_bounds -> + assert (i0 = len0 - 1); + assert (i1 = len1); + (i1, rev_samples) + in + let i1, rev_samples = aux i1 rev_samples in + { acc with i0 = i0 + 1; i1; prev_v0 = v0; rev_samples } + + let finalise { len1; rev_samples; _ } = + if List.length rev_samples <> len1 then failwith "Finalise called too soon"; + List.rev rev_samples + + let resample_vector mode vec0 len1 = + let len0 = List.length vec0 in + if len0 < 2 then invalid_arg "Can't resample curves below 2 points"; + let v00, vec0 = + match vec0 with hd :: tl -> (hd, tl) | _ -> assert false + in + let acc = create_acc mode ~len0 ~len1 ~v00 in + List.fold_left accumulate acc vec0 |> finalise +end + +module Variable_summary = struct + type t = { + max_value : float * int; + min_value : float * int; + mean : float; + diff : float; + distribution : histo; + evolution : curve; + } + [@@deriving repr] + + type acc = { + (* Accumulators *) + first_value : float; + last_value : float; + max_value : float * int; + min_value : float * int; + sum_value : float; + value_count : int; + distribution : Bentov.histogram; + rev_evolution : curve; + ma : Exponential_moving_average.t; + next_in_idx : int; + next_out_idx : int; + (* Constants *) + in_period_count : int; + out_sample_count : int; + evolution_resampling_mode : + [ `Interpolate | `Prev_neighbor | `Next_neighbor ]; + scale : [ `Linear | `Log ]; + } + + let create_acc ~evolution_smoothing ~evolution_resampling_mode + ~distribution_bin_count ~scale ~in_period_count ~out_sample_count = + if in_period_count < 2 then + invalid_arg "in_period_count should be greater than 1"; + if out_sample_count < 2 then + invalid_arg "out_sample_count should be greater than 1"; + { + first_value = Float.nan; + last_value = Float.nan; + max_value = (Float.nan, 0); + min_value = (Float.nan, 0); + sum_value = 0.; + value_count = 0; + distribution = Bentov.create distribution_bin_count; + rev_evolution = []; + ma = + (match evolution_smoothing with + | `None -> Exponential_moving_average.create 0. + | `Ema (half_life_ratio, relevance_threshold) -> + Exponential_moving_average.from_half_life_ratio ~relevance_threshold + half_life_ratio + (float_of_int in_period_count)); + next_in_idx = 0; + next_out_idx = 0; + in_period_count; + out_sample_count; + evolution_resampling_mode; + scale; + } + + let accumulate acc occurences_of_variable_in_period = + let xs = occurences_of_variable_in_period in + let xs = List.filter (fun v -> not (Float.is_nan v)) xs in + let i = acc.next_in_idx in + let sample_count = List.length xs |> float_of_int in + assert (i < acc.in_period_count); + + let accumulate_in_sample + (first, last, ((topv, _) as top), ((botv, _) as bot), histo, ma) v = + let first = if Float.is_nan first then v else first in + let last = if Float.is_nan v then last else v in + let top = if Float.is_nan topv || topv < v then (v, i) else top in + let bot = if Float.is_nan botv || botv > v then (v, i) else bot in + let v = + match acc.scale with + | `Linear -> v + | `Log -> + if Float.is_infinite v then v + else if v <= 0. then + failwith + "Input samples to a Variable_summary should be > 0. when \ + scale=`Log." + else Float.log v + in + let histo = Bentov.add v histo in + let ma = + Exponential_moving_average.update_batch ma v (1. /. sample_count) + in + (first, last, top, bot, histo, ma) + in + let first_value, last_value, max_value, min_value, distribution, ma = + List.fold_left accumulate_in_sample + ( acc.first_value, + acc.last_value, + acc.max_value, + acc.min_value, + acc.distribution, + acc.ma ) + xs + in + let ma = + if sample_count = 0. then Exponential_moving_average.forget ma else ma + in + let rev_evolution, next_out_idx = + let rec aux rev_samples next_out_idx = + match + Resample.should_sample ~i0:i ~len0:acc.in_period_count + ~i1:next_out_idx ~len1:acc.out_sample_count + with + | `Before -> assert false + | `Inside where_in_block -> + let out_sample = + let v_after = Exponential_moving_average.peek_or_nan ma in + if where_in_block = 1. then v_after + else ( + assert (where_in_block > 0.); + assert (next_out_idx > 0); + let v_before = Exponential_moving_average.peek_or_nan acc.ma in + match acc.evolution_resampling_mode with + | `Prev_neighbor -> v_before + | `Next_neighbor -> v_after + | `Interpolate -> + v_before +. ((v_after -. v_before) *. where_in_block)) + in + aux (out_sample :: rev_samples) (next_out_idx + 1) + | `After | `Out_of_bounds -> (rev_samples, next_out_idx) + in + aux acc.rev_evolution acc.next_out_idx + in + + { + acc with + first_value; + last_value; + max_value; + min_value; + sum_value = List.fold_left ( +. ) acc.sum_value xs; + value_count = acc.value_count + List.length xs; + distribution; + rev_evolution; + ma; + next_in_idx = acc.next_in_idx + 1; + next_out_idx; + } + + let finalise acc = + assert (acc.next_out_idx = acc.out_sample_count); + assert (acc.next_out_idx = List.length acc.rev_evolution); + assert (acc.next_in_idx = acc.in_period_count); + let f = match acc.scale with `Linear -> Fun.id | `Log -> Float.exp in + let distribution = + let open Bentov in + bins acc.distribution |> List.map (fun b -> (f b.center, b.count)) + in + let evolution = List.rev_map f acc.rev_evolution in + { + max_value = acc.max_value; + min_value = acc.min_value; + mean = acc.sum_value /. float_of_int acc.value_count; + diff = acc.last_value -. acc.first_value; + distribution; + evolution; + } +end + +module Parallel_folders = struct + type ('row, 'acc, 'v) folder = { + acc : 'acc; + accumulate : 'acc -> 'row -> 'acc; + finalise : 'acc -> 'v; + } + + let folder acc accumulate finalise = { acc; accumulate; finalise } + + type ('res, 'row, 'v) folders = + | F0 : ('res, 'row, 'res) folders + | F1 : + ('row, 'acc, 'v) folder * ('res, 'row, 'rest) folders + -> ('res, 'row, 'v -> 'rest) folders + + type ('res, 'row, 'f, 'rest) open_t = + ('res, 'row, 'rest) folders -> 'f * ('res, 'row, 'f) folders + + let open_ : 'f -> ('res, 'row, 'f, 'f) open_t = + fun constructor folders -> (constructor, folders) + + let app : + type res f v rest acc row. + (res, row, f, v -> rest) open_t -> + (row, acc, v) folder -> + (res, row, f, rest) open_t = + fun open_t folder folders -> open_t (F1 (folder, folders)) + + let ( |+ ) = app + + type ('res, 'row) t = T : 'f * ('res, 'row, 'f) folders -> ('res, 'row) t + + let seal : type res row f. (res, row, f, res) open_t -> (res, row) t = + fun open_t -> + let constructor, folders = open_t F0 in + T (constructor, folders) + + let accumulate : type res row. (res, row) t -> row -> (res, row) t = + fun (T (constructor, folders)) row -> + let rec aux : type v. (res, row, v) folders -> (res, row, v) folders = + function + | F0 -> F0 + | F1 (folder, t) as f -> ( + let acc = folder.acc in + let acc' = folder.accumulate acc row in + let t' = aux t in + (* Avoid reallocating [F1] and [folder] when possible. *) + match (acc == acc', t == t') with + | true, true -> f + | true, false -> F1 (folder, t') + | false, (true | false) -> F1 ({ folder with acc = acc' }, t')) + in + let folders = aux folders in + T (constructor, folders) + + let finalise : type res row. (res, row) t -> res = + let rec aux : type c. (res, row, c) folders -> c -> res = function + | F0 -> Fun.id + | F1 (f, fs) -> + fun constructor -> + let v = f.finalise f.acc in + let finalise_remaining = aux fs in + let constructor = constructor v in + finalise_remaining constructor + in + fun (T (constructor, folders)) -> aux folders constructor +end diff --git a/vendors/irmin/bench/irmin-pack/trace_stat_summary_utils.mli b/vendors/irmin/bench/irmin-pack/trace_stat_summary_utils.mli new file mode 100644 index 0000000000000000000000000000000000000000..72609faeb3fe7d1ba77257ccf8985aefb5cd1155 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_stat_summary_utils.mli @@ -0,0 +1,398 @@ +(** Utilities to summarise data. + + This file is NOT meant to be used from Tezos, as opposed to some other + "trace_*" files. *) + +type histo = (float * int) list [@@deriving repr] +type curve = float list [@@deriving repr] + +val snap_to_integer : significant_digits:int -> float -> float +(** [snap_to_integer ~significant_digits v] is [Float.round v] if [v] is close + to [Float.round v], otherwise the result is [v]. [significant_digits] + defines how close things are. + + Examples: + + When [significant_digits] is [4] and [v] is [42.00001], [snap_to_integer v] + is [42.]. + + When [significant_digits] is [4] and [v] is [42.001], [snap_to_integer v] is + [v]. *) + +val create_pp_real : + ?significant_digits:int -> float list -> Format.formatter -> float -> unit +(** [create_pp_real examples] is [pp_real], a float pretty-printer that adapts + to the [examples] shown to it. + + It is highly recommended, but not mandatory, for all the numbers passed to + [pp_real] to be included in [examples]. + + When all the [examples] are integers, the display may be different. The + examples that aren't integer, but that are very close to be a integers are + counted as integers. [significant_digits] is used internally to snap the + examples to integers. *) + +val create_pp_seconds : float list -> Format.formatter -> float -> unit +(** [create_pp_seconds examples] is [pp_seconds], a time span pretty-printer + that adapts to the [examples] shown to it. + + It is highly recommended, but not mandatory, for all the numbers passed to + [pp_seconds] to be included in [examples]. *) + +val pp_percent : Format.formatter -> float -> unit +(** Pretty prints a percent in a way that always takes 4 chars. + + Examples: [0.] is [" 0%"], [0.00001] is ["0.0%"], [0.003] is ["0.3%"], + [0.15] is [" 15%"], [9.0] is [900%], [700.] is [700x], [410_000.0] is + ["4e6x"] and [1e100] is ["++++"]. + + Negative inputs are undefined. *) + +val approx_transaction_count_of_block_count : ?first_block_idx:int -> int -> int +val approx_operation_count_of_block_count : ?first_block_idx:int -> int -> int + +(** Functional Exponential Moving Average (EMA). *) +module Exponential_moving_average : sig + type t + + val create : ?relevance_threshold:float -> float -> t + (** [create ?relevance_threshold m] is [ema], a functional exponential moving + average. [1. -. m] is the fraction of what's forgotten of the past during + each [update]. + + The value represented by [ema] can be retrieved using [peek_exn ema] or + [peek_or_nan ema]. + + When [m = 0.], all the past is forgotten on each update and each forget. + [peek_exn ema] is either the latest sample fed to an update function or + [nan]. + + When [m] approaches [1.], [peek_exn ema] tends to be the mean of all the + samples seen in the past. + + See + https://en.wikipedia.org/wiki/Moving_average#Exponential_moving_average + + {3 Relevance} + + The value represented by [ema] is built from the {e history} of samples + shown through [update(_batch)]. When that history is empty, the value + can't be calculated, and when the history is too small, or too distant + because of calls to [forget(_batch)], the represented value is very noisy. + + [relevance_threshold] is a threshold on [ema]'s inner [void_fraction], + below which the represented value should be considered relevant, i.e. + [peek_or_nan ema] is not NaN. + + Before any call to [update(_batch)], the represented value is always + irrelevant. + + After a sufficient number of updates (e.g. 1 update in general), the + represented value gets relevant. + + After a sufficient number of forgets, the represented value gets + irrelevant again. + + A good value for [relevance_threshold] is between [momentum] and [1.], so + that right after a call to [update], the value is always relevant. + + {3 Commutativity} + + Adding together two curves independently built with an EMA, is equivalent + to adding the samples beforehand, and using a single EMA. + + In a more more formal way: + + Let [a], [b] be vectors of real values of similar length. + + Let [ema(x)] be the [Exponential_moving_average.map momentum] function + ([float list -> float list]); + + Let [*], [+] and [/] be the element-wise vector multiplication, addition + and division. + + Then [ema(a + b)] is [ema(a) + ema(b)]. + + The same is not true for multiplication and division, [ema(a * b)] is not + [ema(a) * ema(b)], but [exp(ema(log(a * b)))] is + [exp(ema(log(a))) * exp(ema(log(b)))] when all values in [a] and [b] are + strictly greater than 0. *) + + val from_half_life : ?relevance_threshold:float -> float -> t + (** [from_half_life hl] is [ema], a functional exponential moving average. + After [hl] calls to [update], half of the past is forgotten. *) + + val from_half_life_ratio : ?relevance_threshold:float -> float -> float -> t + (** [from_half_life_ratio hl_ratio step_count] is [ema], a functional + exponential moving average. After [hl_ratio * step_count] calls to + [update], half of the past is forgotten. *) + + val map : ?relevance_threshold:float -> float -> float list -> float list + (** [map momentum vec0] is [vec1], a list of float with the same length as + [vec0], where the values have been locally averaged. + + The first element of [vec1] is also the first element of [vec0]. *) + + val update : t -> float -> t + (** Feed a new sample to the EMA. If the sample is not finite (i.e., NaN or + infinite), the represented won't be either. *) + + val update_batch : t -> float -> float -> t + (** [update_batch ema p s] is equivalent to calling [update] [s] times. Modulo + floating point errors. *) + + val forget : t -> t + (** [forget ema] forgets some of the past without the need for samples. The + represented value doesn't change. *) + + val forget_batch : t -> float -> t + (** [forget_batch ema s] is equivalent to calling [forget] [s] times. Modulo + floating point errors.*) + + val is_relevant : t -> bool + (** Indicates whether or not [peek_exn] can be called without raising an + exception. *) + + val peek_exn : t -> float + (** Read the EMA value. *) + + val peek_or_nan : t -> float + (** Read the EMA value. *) + + val momentum : t -> float + val hidden_state : t -> float + val void_fraction : t -> float +end + +(** This [Resample] module offers 3 ways to resample a 1d vector: + + - At the lowest level, using [should_sample]. + - Using [create_acc] / [accumulate] / [finalise]. + - At the highest level, using [resample_vector]. + + Both downsampling and upsampling are possible: + + {v + > upsampling + vec0: | | | | (len0:4) + vec1: | | | | | | (len1:6) + > identity + vec0: | | | | (len0:4) + vec1: | | | | (len1:4) + > downsampling + vec0: | | | | | | (len0:6) + vec1: | | | | (len1:4) + v} + + The first and last point of the input and output sequences are always equal. *) +module Resample : sig + val should_sample : + i0:int -> + len0:int -> + i1:int -> + len1:int -> + [ `After | `Before | `Inside of float | `Out_of_bounds ] + (** When resampling a 1d vector from [len0] to [len1], this function locates a + destination point with index [i1] relative to the range [i0 - 1] excluded + and [i0] included. + + When both [i0] and [i1] equal [0], the result is [`Inside 1.]. + + [len0] and [len1] should be greater or equal to 2. *) + + type acc + + val create_acc : + [ `Interpolate | `Next_neighbor ] -> + len0:int -> + len1:int -> + v00:float -> + acc + (** Creates a resampling accumulator. + + Requires the first point of vec0. *) + + val accumulate : acc -> float -> acc + val finalise : acc -> curve + + val resample_vector : + [< `Interpolate | `Next_neighbor ] -> curve -> int -> curve + (** [resample_vector mode vec0 len1] is [vec1], a curve of length [len1], + created by resampling [vec0]. + + It internally relies on the [should_sample] function. *) +end + +(** Functional summary for a variable that has zero or more occurences per + period. [accumulate] is expected to be called [in_period_count] times before + [finalise] is. + + {3 Stats Gathered} + + - Global (non-nan) max, argmax, min, argmin and mean of the variable. + - The very last non-nan sample encountered minus the very first non-nan + sample encountered. + - Global histogram made of [distribution_bin_count] bins. Option: + [distribution_scale] to control the spreading scale of the bins, either on + a linear or a log scale. Computed using Bentov. + - A curve made of [out_sample_count] points. Options: [evolution_smoothing] + to control the smoothing, either using EMA, or no smoothing at all. + + {3 Histograms} + + The histograms are all computed using https://github.com/barko/bentov. + + [Bentov] computes dynamic histograms without the need for a priori + informations on the distributions, while maintaining a constant memory space + and a marginal CPU footprint. + + The implementation of that library is pretty straightforward, but not + perfect; the CPU footprint doesn't scale well with the number of bins. + + The computed histograms depend on the order of the operations, some marginal + unsabilities are to be expected. + + [Bentov] is good at spreading the bins on the input space. Since some + histograms will be shown on a log plot, the log10 of those values is passed + to [Bentov] instead, but the json will store real seconds. + + {3 Log Scale} + + When a variable has to be displayed on a log scale, the [scale] option can + be set to [`Log] in order for some adjustments to be made. + + In the histogram, the bins have to spread on a log scale. + + When smoothing the evolution, the EMA decay has to be calculated on a log + scale. + + Gotcha: All the input samples should be strictly greater than 0, so that + they don't fail their conversion to log. + + {3 Periods are Decoupled from Samples} + + When a [Variable_summary] ([vs]) is created, the number of periods has to be + declared right away through the [in_period_count] parameter, but [vs] is + very flexible when it comes to the number of samples shown to it on each + period. + + The simplest use case of [vs] is when there is exactly one sample for each + period. In that case, [accumulate acc samples] is called using a list of + length 1. For example: when a period corresponds to a cycle of an algorithm, + and the variable is a timestamp. + + The more advanced use case of [vs] is when there are a varying number a + samples for each period. For example: when a period corresponds to a cycle + of an algorithm, and the variable is the time taken by a buffer flush that + may happen 0, 1 or more times per cycle. + + In that later case, the [evolution] curve may contain NaNs before and after + sample points. + + {3 Possible Future Evolutions} + + - A period-wise histogram, similar to Grafana's heatmaps: "A heatmap is like + a histogram, but over time where each time slice represents its own + histogram.". + + - Variance evolution. Either without smoothing or using exponential moving + variance (see wikipedia). + + - Global variance. + + - Quantile evolution. *) +module Variable_summary : sig + type t = { + max_value : float * int; + min_value : float * int; + mean : float; + diff : float; + distribution : histo; + evolution : curve; + } + [@@deriving repr] + + type acc + + val create_acc : + evolution_smoothing:[ `Ema of float * float | `None ] -> + evolution_resampling_mode:[ `Interpolate | `Next_neighbor | `Prev_neighbor ] -> + distribution_bin_count:int -> + scale:[ `Linear | `Log ] -> + in_period_count:int -> + out_sample_count:int -> + acc + + val accumulate : acc -> float list -> acc + val finalise : acc -> t +end + +(** See [Trace_stat_summary] for an explanation and an example. + + Heavily inspired by the "repr" library. + + Type parameters: + + - ['res] is the output of [finalise]. + - ['f] is the full contructor that creates a ['res]. + - ['v] is the output of [folder.finalise], one parameter of ['f]. + - ['rest] is ['f] or ['res] or somewhere in between. + - ['acc] is the accumulator of one folder. + - ['row] is what needs to be fed to all [folder.accumulate]. + + Typical use case: + + {[ + let pf = + open_ (fun res_a res_b -> my_constructor res_a res_b) + |+ folder my_acc_a my_accumulate_a my_finalise_a + |+ folder my_acc_b my_accumulate_b my_finalise_b + |> seal + in + let res = my_row_sequence |> Seq.fold_left accumulate pf |> finalise in + ]} *) +module Parallel_folders : sig + (** Section 1/3 - Individual folders *) + + type ('row, 'acc, 'v) folder + + val folder : + 'acc -> ('acc -> 'row -> 'acc) -> ('acc -> 'v) -> ('row, 'acc, 'v) folder + (** Create one folder to be passed to an open parallel folder using [|+]. *) + + (** Section 2/3 - Open parallel folder *) + + type ('res, 'row, 'v) folders + type ('res, 'row, 'f, 'rest) open_t + + val open_ : 'f -> ('res, 'row, 'f, 'f) open_t + (** Start building a parallel folder. *) + + val app : + ('res, 'row, 'f, 'v -> 'rest) open_t -> + ('row, 'acc, 'v) folder -> + ('res, 'row, 'f, 'rest) open_t + (** Add a folder to an open parallel folder. *) + + val ( |+ ) : + ('res, 'row, 'f, 'v -> 'rest) open_t -> + ('row, 'acc, 'v) folder -> + ('res, 'row, 'f, 'rest) open_t + (** Alias for [app]. *) + + (** Section 3/3 - Closed parallel folder *) + + type ('res, 'row) t + + val seal : ('res, 'row, 'f, 'res) open_t -> ('res, 'row) t + (** Stop building a parallel folder. + + Gotcha: It may seal a partially applied [f]. *) + + val accumulate : ('res, 'row) t -> 'row -> ('res, 'row) t + (** Forward a row to all registered functional folders. *) + + val finalise : ('res, 'row) t -> 'res + (** Finalise all folders and pass their result to the user-defined function + provided to [open_]. *) +end diff --git a/vendors/irmin/bench/irmin-pack/trace_stats.ml b/vendors/irmin/bench/irmin-pack/trace_stats.ml new file mode 100644 index 0000000000000000000000000000000000000000..6ad6d535986839ab94d0320a7ba30cbd63f161b1 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/trace_stats.ml @@ -0,0 +1,213 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [trace_stats.exe]. + + This file is NOT meant to be used from Tezos, as opposed to some other + "trace_*" files. *) + +open Irmin_traces +module Def = Trace_definitions.Stat_trace +module Summary = Trace_stat_summary + +let is_trace_magic s = Trace_common.Magic.to_string Def.magic = s + +let summarise path = + Summary.(summarise path |> Fmt.pr "%a\n" (Irmin.Type.pp_json t)) + +let class_of_path p = + let chan = open_in_bin p in + if in_channel_length chan < 8 then + Fmt.invalid_arg "File \"%s\" should be a stat trace or a json." p; + let magic = really_input_string chan 8 in + close_in chan; + if is_trace_magic magic then + let block_count = + Def.open_reader p + |> snd + |> Seq.fold_left + (fun count op -> match op with `Commit _ -> count + 1 | _ -> count) + 0 + in + `Trace block_count + else + let chan = open_in_bin p in + let raw = really_input_string chan (in_channel_length chan) in + close_in chan; + match Irmin.Type.of_json_string Summary.t raw with + | Error (`Msg msg) -> + Fmt.invalid_arg + "File \"%s\" should be a stat trace or a json.\nError: %s" p msg + | Ok s -> `Summary s + +let pp name_per_path paths cols_opt = + let class_per_path = List.map class_of_path paths in + let block_count = + (* When pretty printing, all the summaries will have to have the same number of + blocks, i.e. the smallest of all inputs. *) + let trace_lengths = + List.filter_map + (function `Trace v -> Some v | `Summary _ -> None) + class_per_path + in + let summary_lengths = + List.filter_map + (function `Trace _ -> None | `Summary s -> Some s.Summary.block_count) + class_per_path + in + let s = List.length summary_lengths > 0 in + let t = List.length trace_lengths > 0 in + let min_trace_length = List.fold_left min max_int trace_lengths in + let min_summary_length = List.fold_left min max_int summary_lengths in + let max_summary_length = List.fold_left max 0 summary_lengths in + if s && min_summary_length <> max_summary_length then + invalid_arg + "Can't pretty print 2 summaries with a different number of blocks."; + if s && t && min_summary_length > min_trace_length then + invalid_arg + "Can't pretty print a trace alongside a summary that has a higher \ + block count."; + min min_trace_length min_summary_length + in + let summaries = + List.map2 + (fun path -> function + | `Summary s -> s + | `Trace _ -> Summary.summarise ~block_count path) + paths class_per_path + in + let col_count = + match cols_opt with + | Some v -> v + | None -> if List.length summaries > 1 then 4 else 5 + in + Fmt.pr "%a\n" (Trace_stat_summary_pp.pp col_count) (name_per_path, summaries) + +let pp paths named_paths cols_opt = + let name_per_path, paths = + List.mapi (fun i v -> (string_of_int i, v)) paths @ named_paths + |> List.split + in + if List.length paths = 0 then + invalid_arg "trace_stats.exe pp: At least one path should be provided"; + pp name_per_path paths cols_opt + +let summary_to_cb path = + let chan = open_in_bin path in + let raw = really_input_string chan (in_channel_length chan) in + close_in chan; + let s = + match Irmin.Type.of_json_string Summary.t raw with + | Error (`Msg msg) -> + Fmt.invalid_arg "File \"%s\" should be a summary json.\nError: %s" path + msg + | Ok s -> s + in + Trace_stat_summary_cb.(of_summary s |> Fmt.pr "%a\n" (Irmin.Type.pp_json t)) + +open Cmdliner + +let term_summarise = + let stat_trace_file = + let doc = Arg.info ~docv:"PATH" ~doc:"A stat trace file" [] in + Arg.(required @@ pos 0 (some string) None doc) + in + Term.(const summarise $ stat_trace_file) + +let term_pp = + let arg_indexed_files = + let open Arg in + let a = pos_all non_dir_file [] (info [] ~docv:"FILE") in + value a + in + let arg_named_files = + let open Arg in + let a = + opt_all (pair string non_dir_file) [] + (info [ "f"; "named-file" ] + ~doc: + "A comma-separated pair of short name / path to trace or summary. \ + The short name is used to tag the rows inside the pretty printed \ + table.") + in + value a + in + let arg_columns = + let open Arg in + let doc = + Arg.info ~doc:"Number of sample columns to show." [ "c"; "columns" ] + in + let a = opt (some int) None doc in + value a + in + Term.(const pp $ arg_indexed_files $ arg_named_files $ arg_columns) + +let term_cb = + let summary_file = + let doc = Arg.info ~docv:"PATH" ~doc:"A stat trace summary file" [] in + Arg.(required @@ pos 0 (some string) None doc) + in + Term.(const summary_to_cb $ summary_file) + +let deprecated_info = (Term.info [@alert "-deprecated"]) +let deprecated_exit = (Term.exit [@alert "-deprecated"]) +let deprecated_eval_choice = (Term.eval_choice [@alert "-deprecated"]) + +let () = + let man = [] in + let i = + deprecated_info ~man + ~doc:"Processing of stat traces and stat trace summaries." "trace_stats" + in + + let man = + [ + `P "From stat trace (repr) to summary (json)."; + `S "EXAMPLE"; + `P "trace_stats.exe summarise run0.repr > run0.json"; + ] + in + let j = deprecated_info ~man ~doc:"Stat Trace to Summary" "summarise" in + + let man = + [ + `P + "Accepts both stat traces (repr) and summaries (json). The file type \ + is automatically infered."; + `P + "When a single file is provided, a subset of the summary of that file \ + is computed and shown."; + `P + "When multiple files are provided, a subset of the summary of each \ + file is computed and shown in a way that makes comparisons between \ + files easy."; + `S "EXAMPLES"; + `P "trace_stats.exe pp run0.json"; + `Noblank; + `P "trace_stats.exe pp run1.repr"; + `Noblank; + `P "trace_stats.exe pp run0.json run1.repr run3.json"; + `Noblank; + `P "trace_stats.exe pp -f r0,run0.json -f r1,run1.repr"; + ] + in + let k = deprecated_info ~man ~doc:"Comparative Pretty Printing" "pp" in + let l = + deprecated_info ~man ~doc:"Summary JSON to Continous Benchmarks JSON" "cb" + in + deprecated_exit + @@ deprecated_eval_choice (term_summarise, i) + [ (term_summarise, j); (term_pp, k); (term_cb, l) ] diff --git a/vendors/irmin/bench/irmin-pack/tree.ml b/vendors/irmin/bench/irmin-pack/tree.ml new file mode 100644 index 0000000000000000000000000000000000000000..0155bb10c4b4aec21e0c328cc191c3adcd674536 --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/tree.ml @@ -0,0 +1,611 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Bench_common +open Irmin.Export_for_backends +open Irmin_traces + +type config = { + ncommits : int; + number_of_commits_to_replay : int; + depth : int; + nchain_trees : int; + width : int; + nlarge_trees : int; + store_dir : string; + path_conversion : [ `None | `V1 | `V0_and_v1 | `V0 ]; + inode_config : int * int; + store_type : [ `Pack | `Pack_mem ]; + freeze_commit : int; + replay_trace_path : string; + artefacts_path : string; + keep_store : bool; + keep_stat_trace : bool; + no_summary : bool; + empty_blobs : bool; + gc_every : int; + gc_distance_in_the_past : int; + gc_wait_after : int; +} + +module type Store = sig + type store_config = config + type key + + include + Irmin.Generic_key.KV + with type Schema.Contents.t = bytes + and type commit_key = key + and type node_key = key + and type contents_key = key + + type on_commit := int -> Hash.t -> unit Lwt.t + type on_end := unit -> unit Lwt.t + + val create_repo : + root:string -> store_config -> (Repo.t * on_commit * on_end) Lwt.t + + val gc : repo -> commit_key -> unit Lwt.t + val finalise_gc : ?wait:bool -> repo -> bool Lwt.t +end + +let pp_inode_config ppf (entries, stable_hash) = + Format.fprintf ppf "[%d, %d]" entries stable_hash + +let pp_store_type ppf = function + | `Pack -> Format.fprintf ppf "[pack store]" + | `Pack_mem -> Format.fprintf ppf "[pack-mem store]" + +module Benchmark = struct + type result = { time : float; size : int } + + let run config f = + let+ time, res = with_timer f in + let size = FSHelper.get_size config.store_dir in + ({ time; size }, res) + + let pp_results ppf result = + Format.fprintf ppf "Total time: %f@\nSize on disk: %d M" result.time + result.size +end + +module Bench_suite (Store : Store) = struct + module Info = Info (Store.Info) + module Key = Store.Backend.Commit.Key + module Trees = Generate_trees (Store) + module Trace_replay = Trace_replay.Make (Store) + + let checkout_and_commit repo prev_commit f = + match prev_commit with + | None -> + let tree = Store.Tree.empty () in + let* tree = f tree in + Store.Commit.v repo ~info:(Info.f ()) ~parents:[] tree + | Some prev_commit -> ( + let prev_commit = Store.Commit.key prev_commit in + Store.Commit.of_key repo prev_commit >>= function + | None -> Lwt.fail_with "commit not found" + | Some commit -> + let tree = Store.Commit.tree commit in + let* tree = f tree in + Store.Commit.v repo ~info:(Info.f ()) ~parents:[ prev_commit ] tree) + + let add_commits ~message repo ncommits on_commit on_end f () = + with_progress_bar ~message ~n:ncommits ~unit:"commit" @@ fun prog -> + let rec aux c i = + if i >= ncommits then on_end () + else + let* c' = checkout_and_commit repo c f in + let* () = on_commit i (Store.Commit.hash c') in + prog 1; + aux (Some c') (i + 1) + in + aux None 0 + + let run_large config = + reset_stats (); + let root = config.store_dir in + let* repo, on_commit, on_end = Store.create_repo ~root config in + let* result, () = + Trees.add_large_trees config.width config.nlarge_trees + |> add_commits ~message:"Playing large mode" repo config.ncommits + on_commit on_end + |> Benchmark.run config + in + let+ () = Store.Repo.close repo in + fun ppf -> + Format.fprintf ppf + "Large trees mode on inode config %a, %a: %d commits, each consisting \ + of %d large trees of %d entries@\n\ + %a" + pp_inode_config config.inode_config pp_store_type config.store_type + config.ncommits config.nlarge_trees config.width Benchmark.pp_results + result + + let run_chains config = + reset_stats (); + let root = config.store_dir in + let* repo, on_commit, on_end = Store.create_repo ~root config in + let* result, () = + Trees.add_chain_trees config.depth config.nchain_trees + |> add_commits ~message:"Playing chain mode" repo config.ncommits + on_commit on_end + |> Benchmark.run config + in + let+ () = Store.Repo.close repo in + fun ppf -> + Format.fprintf ppf + "Chain trees mode on inode config %a, %a: %d commits, each consisting \ + of %d chains of depth %d@\n\ + %a" + pp_inode_config config.inode_config pp_store_type config.store_type + config.ncommits config.nchain_trees config.depth Benchmark.pp_results + result + + let run_read_trace config = + let replay_config : _ Irmin_traces.Trace_replay.config = + { + number_of_commits_to_replay = config.number_of_commits_to_replay; + path_conversion = config.path_conversion; + inode_config = config.inode_config; + store_type = + (config.store_type :> [ `Pack | `Pack_layered | `Pack_mem ]); + replay_trace_path = config.replay_trace_path; + artefacts_path = config.artefacts_path; + keep_store = config.keep_store; + keep_stat_trace = config.keep_stat_trace; + empty_blobs = config.empty_blobs; + return_type = Summary; + gc_every = config.gc_every; + gc_distance_in_the_past = config.gc_distance_in_the_past; + gc_wait_after = config.gc_wait_after; + } + in + if config.no_summary then + let+ () = + Trace_replay.run config { replay_config with return_type = Unit } + in + fun _ppf -> () + else + let+ summary = Trace_replay.run config replay_config in + fun ppf -> + if not config.no_summary then ( + let p = Filename.concat config.artefacts_path "stat_summary.json" in + Trace_stat_summary.save_to_json summary p; + Format.fprintf ppf "%a" + (Trace_stat_summary_pp.pp 5) + ([ "" ], [ summary ])) +end + +module Make_basic (Maker : functor (_ : Irmin_pack.Conf.S) -> + Irmin_pack.Maker) +(Conf : Irmin_pack.Conf.S) = +struct + type store_config = config + + module Store = struct + open Maker (Conf) + include Make (Irmin_tezos.Schema) + end + + include Store + + type key = commit_key + + let indexing_strategy = Irmin_pack.Indexing_strategy.minimal + + let create_repo ~root _config = + let conf = + Irmin_pack.config ~readonly:false ~fresh:true ~indexing_strategy root + in + prepare_artefacts_dir root; + let* repo = Store.Repo.v conf in + let on_commit _ _ = Lwt.return_unit in + let on_end () = Lwt.return_unit in + Lwt.return (repo, on_commit, on_end) + + let gc repo key = + let* (_launched : bool) = + Store.start_gc ~unlink:true ~throttle:`Block repo key + in + Lwt.return_unit +end + +module Make_store_mem = Make_basic (Irmin_pack_mem.Maker) +module Make_store_pack = Make_basic (Irmin_pack_unix.Maker) + +module type B = sig + val run_large : config -> (Format.formatter -> unit) Lwt.t + val run_chains : config -> (Format.formatter -> unit) Lwt.t + val run_read_trace : config -> (Format.formatter -> unit) Lwt.t +end + +let store_of_config config = + let entries', stable_hash' = config.inode_config in + let module Conf = struct + include Irmin_tezos.Conf + + let entries = entries' + let stable_hash = stable_hash' + end in + match config.store_type with + | `Pack -> (module Bench_suite (Make_store_pack (Conf)) : B) + | `Pack_mem -> (module Bench_suite (Make_store_mem (Conf)) : B) + +type suite_elt = { + mode : [ `Read_trace | `Chains | `Large ]; + speed : [ `Quick | `Slow | `Custom ]; + run : config -> (Format.formatter -> unit) Lwt.t; +} + +let suite : suite_elt list = + [ + { + mode = `Read_trace; + speed = `Quick; + run = + (fun config -> + let config = + { config with inode_config = (32, 256); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_read_trace config); + }; + { + mode = `Read_trace; + speed = `Slow; + run = + (fun config -> + let config = + { config with inode_config = (32, 256); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_read_trace config); + }; + { + mode = `Chains; + speed = `Quick; + run = + (fun config -> + let config = + { config with inode_config = (32, 256); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_chains config); + }; + { + mode = `Chains; + speed = `Slow; + run = + (fun config -> + let config = + { config with inode_config = (2, 5); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_chains config); + }; + { + mode = `Large; + speed = `Quick; + run = + (fun config -> + let config = + { config with inode_config = (32, 256); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_large config); + }; + { + mode = `Large; + speed = `Slow; + run = + (fun config -> + let config = + { config with inode_config = (2, 5); store_type = `Pack } + in + let (module Store) = store_of_config config in + Store.run_large config); + }; + { + mode = `Read_trace; + speed = `Custom; + run = + (fun config -> + let (module Store) = store_of_config config in + Store.run_read_trace config); + }; + ] + +let get_suite suite_filter = + List.filter + (fun { mode; speed; _ } -> + match (suite_filter, speed, mode) with + | `Slow, `Slow, `Read_trace -> + (* The suite contains several `Read_trace benchmarks, let's keep the + slow one only *) + true + | `Slow, _, `Read_trace -> false + | `Slow, (`Slow | `Quick), _ -> true + | `Quick, `Quick, _ -> true + | `Custom_trace, `Custom, `Read_trace -> true + | `Custom_chains, `Custom, `Chains -> true + | `Custom_large, `Custom, `Large -> true + | (`Slow | `Quick | `Custom_trace | `Custom_chains | `Custom_large), _, _ + -> + false) + suite + +let main () ncommits number_of_commits_to_replay suite_filter inode_config + store_type freeze_commit path_conversion depth width nchain_trees + nlarge_trees replay_trace_path artefacts_path keep_store keep_stat_trace + no_summary empty_blobs gc_every gc_distance_in_the_past gc_wait_after = + let default = match suite_filter with `Quick -> 10000 | _ -> 13315 in + let number_of_commits_to_replay = + Option.value ~default number_of_commits_to_replay + in + let config = + { + ncommits; + number_of_commits_to_replay; + store_dir = Filename.concat artefacts_path "store"; + path_conversion; + depth; + width; + nchain_trees; + nlarge_trees; + replay_trace_path; + inode_config; + store_type; + freeze_commit; + artefacts_path; + keep_store; + keep_stat_trace; + no_summary; + empty_blobs; + gc_every; + gc_distance_in_the_past; + gc_wait_after; + } + in + Printexc.record_backtrace true; + Random.self_init (); + (* Enforce the older allocation policy, for consistency of the existing + results. *) + Gc.set { (Gc.get ()) with Gc.allocation_policy = 0 }; + FSHelper.rm_dir config.store_dir; + let suite = get_suite suite_filter in + let run_benchmarks () = Lwt_list.map_s (fun b -> b.run config) suite in + let results = + Lwt_main.run + (Lwt.finalize run_benchmarks (fun () -> + if keep_store then ( + [%logs.app "Store kept at %s" config.store_dir]; + let ( / ) = Filename.concat in + let ro p = if Sys.file_exists p then Unix.chmod p 0o444 in + ro (config.store_dir / "store.branches"); + ro (config.store_dir / "store.dict"); + ro (config.store_dir / "store.pack"); + ro (config.store_dir / "index" / "data"); + ro (config.store_dir / "index" / "log"); + ro (config.store_dir / "index" / "log_async")) + else FSHelper.rm_dir config.store_dir; + Lwt.return_unit)) + in + [%logs.app "%a@." Fmt.(list ~sep:(any "@\n@\n") (fun ppf f -> f ppf)) results] + +open Cmdliner + +let mode = + let mode = + [ + ("slow", `Slow); + ("quick", `Quick); + ("trace", `Custom_trace); + ("chains", `Custom_chains); + ("large", `Custom_large); + ] + in + let doc = Arg.info ~doc:(Arg.doc_alts_enum mode) [ "mode" ] in + Arg.(value @@ opt (Arg.enum mode) `Slow doc) + +let inode_config = + let doc = Arg.info ~doc:"Inode config" [ "inode-config" ] in + Arg.(value @@ opt (pair int int) (32, 256) doc) + +let store_type = + let mode = [ ("pack", `Pack); ("pack-mem", `Pack_mem) ] in + let doc = Arg.info ~doc:(Arg.doc_alts_enum mode) [ "store-type" ] in + Arg.(value @@ opt (Arg.enum mode) `Pack doc) + +let freeze_commit = + let doc = + Arg.info + ~doc:"Index of the commit after which to start the layered store freeze." + [ "freeze-commit" ] + in + Arg.(value @@ opt int 1664 doc) + +let path_conversion = + let mode = + [ ("none", `None); ("v0", `V0); ("v1", `V1); ("v0+v1", `V0_and_v1) ] + in + let doc = Arg.info ~doc:(Arg.doc_alts_enum mode) [ "p"; "path-conversion" ] in + Arg.(value @@ opt (Arg.enum mode) `None doc) + +let ncommits = + let doc = + Arg.info ~doc:"Number of commits for the large and chain modes." + [ "n"; "ncommits" ] + in + Arg.(value @@ opt int 2 doc) + +let number_of_commits_to_replay = + let doc = + Arg.info ~doc:"Number of commits to read from trace." [ "ncommits-trace" ] + in + Arg.(value @@ opt (some int) None doc) + +let keep_store = + let doc = + Arg.info ~doc:"Whether or not the irmin store on disk should be kept." + [ "keep-store" ] + in + Arg.(value @@ flag doc) + +let no_summary = + let doc = + Arg.info + ~doc: + "Whether or not the stat trace should be converted to a summary at the \ + end of a replay." + [ "no-summary" ] + in + Arg.(value @@ flag doc) + +let keep_stat_trace = + let doc = + Arg.info + ~doc: + "Whether or not the stat trace should be discarded are the end, after \ + the summary has been saved the disk." + [ "keep-stat-trace" ] + in + Arg.(value @@ flag doc) + +let empty_blobs = + let doc = + Arg.info + ~doc: + "Whether or not the blobs added to the store should be the empty \ + string, during trace replay. This greatly increases the replay speed." + [ "empty-blobs" ] + in + Arg.(value @@ flag doc) + +let depth = + let doc = + Arg.info ~doc:"Depth of a commit's tree in chains-mode." [ "d"; "depth" ] + in + Arg.(value @@ opt int 1000 doc) + +let nchain_trees = + let doc = + Arg.info ~doc:"Number of chain trees per commit in chains-mode." + [ "c"; "nchain" ] + in + Arg.(value @@ opt int 1 doc) + +let width = + let doc = + Arg.info ~doc:"Width of a commit's tree in large-mode." [ "w"; "width" ] + in + Arg.(value @@ opt int 1000000 doc) + +let nlarge_trees = + let doc = + Arg.info ~doc:"Number of large trees per commit in large-mode." + [ "l"; "nlarge" ] + in + Arg.(value @@ opt int 1 doc) + +let replay_trace_path = + let doc = + Arg.info ~docv:"PATH" ~doc:"Trace of Tezos operations to be replayed." [] + in + Arg.(required @@ pos 0 (some string) None doc) + +let artefacts_path = + let doc = + Arg.info ~docv:"PATH" ~doc:"Destination of the bench artefacts." + [ "artefacts" ] + in + Arg.(value @@ opt string default_artefacts_dir doc) + +let setup_log = + Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) + +let gc_every = + let doc = Arg.info ~doc:"Distance between calls to GC" [ "gc-every" ] in + Arg.(value @@ opt int 1000 doc) + +let gc_distance_in_the_past = + let doc = + Arg.info ~doc:"Distance between the GC commit and the latest commit" + [ "gc-distance-in-the-past" ] + in + Arg.(value @@ opt int 5000 doc) + +let gc_wait_after = + let doc = + Arg.info + ~doc: + "How many commits separate the start of a GC and the moment we wait \ + for the end of it" + [ "gc-wait-after" ] + in + Arg.(value @@ opt int 0 doc) + +let main_term = + Term.( + const main + $ setup_log + $ ncommits + $ number_of_commits_to_replay + $ mode + $ inode_config + $ store_type + $ freeze_commit + $ path_conversion + $ depth + $ width + $ nchain_trees + $ nlarge_trees + $ replay_trace_path + $ artefacts_path + $ keep_store + $ keep_stat_trace + $ no_summary + $ empty_blobs + $ gc_every + $ gc_distance_in_the_past + $ gc_wait_after) + +let deprecated_info = (Term.info [@alert "-deprecated"]) +let deprecated_exit = (Term.exit [@alert "-deprecated"]) +let deprecated_eval = (Term.eval [@alert "-deprecated"]) + +let () = + let man = + [ + `S "DESCRIPTION"; + `P + "Benchmarks for tree operations. Requires traces of operations, \ + download them (`wget trace.repr`) from:"; + `P + "Trace with $(b,10310) commits \ + http://data.tarides.com/irmin/data4_10310commits.repr"; + `P + "Trace with $(b,100066) commits \ + http://data.tarides.com/irmin/data4_100066commits.repr"; + `P + "Trace with $(b,1343496) commits \ + http://data.tarides.com/irmin/data_1343496commits.repr"; + ] + in + let info = + deprecated_info ~man ~doc:"Benchmarks for tree operations" "tree" + in + deprecated_exit @@ deprecated_eval (main_term, info) diff --git a/vendors/irmin/bench/irmin-pack/tree.mli b/vendors/irmin/bench/irmin-pack/tree.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/bench/irmin-pack/tree.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/bench/irmin/data/bench_fixed_size_string_set.ml b/vendors/irmin/bench/irmin/data/bench_fixed_size_string_set.ml new file mode 100644 index 0000000000000000000000000000000000000000..29f29dfb38f50b0627d95e5fb90412559552fcf4 --- /dev/null +++ b/vendors/irmin/bench/irmin/data/bench_fixed_size_string_set.ml @@ -0,0 +1,124 @@ +let stabilize_garbage_collector () = + let rec go fail last_heap_live_words = + if fail <= 0 then + failwith "Unable to stabilize the number of live words in the major heap"; + Gc.compact (); + let stat = Gc.stat () in + if stat.Gc.live_words <> last_heap_live_words then + go (fail - 1) stat.Gc.live_words + in + go 10 0 + +let allocated_words () = + let s = Gc.quick_stat () in + s.minor_words +. s.major_words -. s.promoted_words + +let open_stat_file name = + let stat_file = + let rnd = Random.bits () land 0xFFFFFF in + let ( / ) = Filename.concat in + "_build" / Printf.sprintf "%s-%06x.csv" name rnd + in + Printf.printf "Sending stats to '%s'\n%!" stat_file; + let out = open_out stat_file in + Printf.fprintf out + "entries,implementation,reachable_words,allocated_words,time(ns)\n"; + out + +(** Compute metrics of various hashset implementations, as a function of the + number of entries: + + - total size in memory + - extra allocations per entry + - cost of [add] per entry + + Stats are emitted to a trace file to be interpreted by scripts in + [./analysis]. *) + +module type S = sig + type t + type elt := string + + val implementation_name : string + val create : unit -> t + val add : t -> elt -> unit + val reachable_words : t -> int +end + +module Elt = struct + type t = string + + let equal = String.equal + let elt_length = 32 + let hash elt = Int64.to_int Bytes.(get_int64_be (unsafe_of_string elt) 0) + + let hash_substring t ~off ~len:_ = + Int64.to_int (Bigstringaf.get_int64_be t off) +end + +module Stringset_irmin : S = struct + module T = Irmin_data.Fixed_size_string_set + + type t = T.t + + let implementation_name = "irmin" + + let create () = + let open Elt in + T.create ~elt_length ~hash ~hash_substring ~initial_slots:0 () + + let add = T.add_exn + let reachable_words = T.reachable_words +end + +module Stringset_stdlib : S = struct + module T = Stdlib.Hashtbl.Make (Elt) + + type t = unit T.t + + let implementation_name = "stdlib" + let create () = T.create 0 + let add t k = T.add t k () + let reachable_words (t : t) = Obj.reachable_words (Obj.repr t) +end + +let random_string state = + let b = Bytes.create Elt.elt_length in + for i = 0 to Elt.elt_length - 1 do + Bytes.set b i (Char.chr (Random.State.int state 256)) + done; + Bytes.unsafe_to_string b + +let run_loop ~random_state ~out (module Hashset : S) = + let t = Hashset.create () + and iterations = 300_000 + and start_time = Mtime_clock.counter () + and last = ref Mtime.Span.zero + and initial_allocations = allocated_words () in + stabilize_garbage_collector (); + for i = 1 to iterations do + Hashset.add t (random_string random_state); + if i mod 1_000 = 0 then ( + let time = Mtime_clock.count start_time in + let diff = Mtime.Span.abs_diff time !last in + let reachable_words = Hashset.reachable_words t in + Printf.eprintf "\r%s : %#d / %#d%!" Hashset.implementation_name i + iterations; + Printf.fprintf out "%d,%s,%d,%f,%Ld\n%!" i Hashset.implementation_name + reachable_words + (allocated_words () -. initial_allocations) + (Int64.div (Mtime.Span.to_uint64_ns diff) 1_000L); + last := Mtime_clock.count start_time) + done; + Printf.eprintf "\r%s : done\x1b[K\n%!" Hashset.implementation_name + +let () = + Random.self_init (); + let seed = Random.int 0x3fff_ffff in + let random_state = Random.State.make [| seed |] in + Printf.eprintf "Random seed: %d\n%!" seed; + let out = open_stat_file "hashset-memory-usage" in + List.iter + (run_loop ~random_state ~out) + [ (module Stringset_irmin); (module Stringset_stdlib) ]; + Printf.printf "\nDone\n" diff --git a/vendors/irmin/bench/irmin/data/dune b/vendors/irmin/bench/irmin/data/dune new file mode 100644 index 0000000000000000000000000000000000000000..0d116268a7bc8808a2560e6663c7b6107e2e6731 --- /dev/null +++ b/vendors/irmin/bench/irmin/data/dune @@ -0,0 +1,3 @@ +(executable + (name bench_fixed_size_string_set) + (libraries irmin.data mtime mtime.clock.os)) diff --git a/vendors/irmin/codecov.yml b/vendors/irmin/codecov.yml new file mode 100644 index 0000000000000000000000000000000000000000..714a8ae74641f861008239732ad56c2a120edb83 --- /dev/null +++ b/vendors/irmin/codecov.yml @@ -0,0 +1,4 @@ +comment: + layout: diff + behaviour: default + require_changes: true diff --git a/vendors/irmin/dune b/vendors/irmin/dune new file mode 100644 index 0000000000000000000000000000000000000000..fe7d302bca28cbf0c3717abe54159b2ae6cc248a --- /dev/null +++ b/vendors/irmin/dune @@ -0,0 +1,6 @@ +(vendored_dirs vendors) + +(mdx + (files README.md) + (package irmin-cli) + (packages irmin-cli)) diff --git a/vendors/irmin/dune-project b/vendors/irmin/dune-project new file mode 100644 index 0000000000000000000000000000000000000000..f9600ff68f4831e8ef41a7d101fd472e0e065e31 --- /dev/null +++ b/vendors/irmin/dune-project @@ -0,0 +1,4 @@ +(lang dune 2.9) +(name irmin) +(cram enable) +(using mdx 0.1) diff --git a/vendors/irmin/examples/config.ml b/vendors/irmin/examples/config.ml new file mode 100644 index 0000000000000000000000000000000000000000..f15305a8b8dc56d6c437f13beeab56c5d2c7c2b6 --- /dev/null +++ b/vendors/irmin/examples/config.ml @@ -0,0 +1,22 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let root = "/tmp/irmin/test" + +let init () = + let _ = Sys.command (Printf.sprintf "rm -rf %s" root) in + let _ = Sys.command (Printf.sprintf "mkdir -p %s" root) in + Irmin_unix.set_listen_dir_hook () diff --git a/vendors/irmin/examples/custom_graphql.ml b/vendors/irmin/examples/custom_graphql.ml new file mode 100644 index 0000000000000000000000000000000000000000..cf4e1c9bf3d71a3c42c2af10c4a73b518b1e406b --- /dev/null +++ b/vendors/irmin/examples/custom_graphql.ml @@ -0,0 +1,121 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Example of using irmin-graphql with custom types *) + +open Lwt.Syntax + +module Car = struct + type color = Black | White | Other of string [@@deriving irmin] + + type t = { + license : string; + year : int32; + make_and_model : string * string; + color : color; + owner : string; + } + [@@deriving irmin] + + let merge = Irmin.Merge.(option (idempotent t)) +end + +module Store = Irmin_git_unix.Mem.KV (Car) + +module Custom_types = struct + module Defaults = Irmin_graphql.Server.Default_types (Store) + module Path = Defaults.Path + module Metadata = Defaults.Metadata + module Hash = Defaults.Hash + module Branch = Defaults.Branch + module Commit_key = Defaults.Commit_key + module Contents_key = Defaults.Contents_key + module Node_key = Defaults.Node_key + + module Contents = struct + open Graphql_lwt + + let color_values = + Schema. + [ + enum_value "BLACK" ~value:Car.Black; + enum_value "WHITE" ~value:Car.White; + ] + + let schema_typ = + Schema.( + obj "Car" ~fields:(fun _ -> + [ + field "license" ~typ:(non_null string) ~args:[] + ~resolve:(fun _ car -> car.Car.license); + field "year" ~typ:(non_null int) ~args:[] ~resolve:(fun _ car -> + Int32.to_int car.Car.year); + field "make" ~typ:(non_null string) ~args:[] + ~resolve:(fun _ car -> fst car.Car.make_and_model); + field "model" ~typ:(non_null string) ~args:[] + ~resolve:(fun _ car -> snd car.Car.make_and_model); + field "color" ~typ:(non_null string) ~args:[] + ~resolve:(fun _ car -> car.Car.license); + field "owner" ~typ:(non_null string) ~args:[] + ~resolve:(fun _ car -> car.Car.owner); + ])) + + let color = Schema.Arg.enum "Color" ~values:color_values + + let arg_typ = + Schema.Arg.( + obj "CarInput" + ~fields: + [ + arg "license" ~typ:(non_null string); + arg "year" ~typ:(non_null int); + arg "make" ~typ:(non_null string); + arg "model" ~typ:(non_null string); + arg "color" ~typ:(non_null color); + arg "owner" ~typ:(non_null string); + ] + ~coerce:(fun license year make model color owner -> + { + Car.license; + year = Int32.of_int year; + make_and_model = (make, model); + color; + owner; + })) + end +end + +module Remote = struct + let remote = Some Store.remote +end + +module Server = + Irmin_graphql_unix.Server.Make_ext (Store) (Remote) (Custom_types) + +let main () = + Config.init (); + let config = Irmin_git.config Config.root in + let* repo = Store.Repo.v config in + let server = Server.v repo in + let src = "localhost" in + let port = 9876 in + let* ctx = Conduit_lwt_unix.init ~src () in + let ctx = Cohttp_lwt_unix.Net.init ~ctx () in + let on_exn exn = Printf.printf "on_exn: %s" (Printexc.to_string exn) in + Printf.printf "Visit GraphiQL @ http://%s:%d/graphql\n%!" src port; + Cohttp_lwt_unix.Server.create ~on_exn ~ctx ~mode:(`TCP (`Port port)) server + +let () = Lwt_main.run (main ()) diff --git a/vendors/irmin/examples/custom_merge.ml b/vendors/irmin/examples/custom_merge.ml new file mode 100644 index 0000000000000000000000000000000000000000..af70d47ae7d4f1b32ef5b75d411a6555470e25a8 --- /dev/null +++ b/vendors/irmin/examples/custom_merge.ml @@ -0,0 +1,165 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) +open Lwt.Syntax +open Astring + +let what = + "This example demonstrates custom merges on Irmin datastructures.\n\n\ + It models log files as a sequence of lines, ordered by timestamps.\n\n\ + The log files of `branch 1` and `branch 2` are merged by using the following \n\ + strategy:\n\ + \ - find the log file corresponding the lowest common ancestor: `lca`\n\ + \ - remove the prefix `lca` from `branch 1`; this gives `l1`;\n\ + \ - remove the prefix `lca` from `branch 2`; this gives `l2`;\n\ + \ - interleave `l1` and `l2` by ordering the timestamps; This gives `l3`;\n\ + \ - concatenate `lca` and `l3`; This gives the final result." + +let time = ref 0L +let failure fmt = Fmt.kstr failwith fmt + +(* A log entry *) +module Entry : sig + include Irmin.Type.S + + val v : string -> t + val timestamp : t -> int64 +end = struct + type t = { timestamp : int64; message : string } [@@deriving irmin] + + let compare x y = Int64.compare x.timestamp y.timestamp + + let v message = + time := Int64.add 1L !time; + { timestamp = !time; message } + + let timestamp t = t.timestamp + let pp ppf { timestamp; message } = Fmt.pf ppf "%04Ld: %s" timestamp message + + let of_string str = + match String.cut ~sep:": " str with + | None -> Error (`Msg ("invalid entry: " ^ str)) + | Some (x, message) -> ( + try Ok { timestamp = Int64.of_string x; message } + with Failure e -> Error (`Msg e)) + + let t = Irmin.Type.like ~pp ~of_string ~compare t +end + +(* A log file *) +module Log : sig + include Irmin.Contents.S + + val add : t -> Entry.t -> t + val empty : t +end = struct + type t = Entry.t list [@@deriving irmin] + + let empty = [] + let pp_entry = Irmin.Type.pp Entry.t + let lines ppf l = List.iter (Fmt.pf ppf "%a\n" pp_entry) (List.rev l) + + let of_string str = + let lines = String.cuts ~empty:false ~sep:"\n" str in + try + List.fold_left + (fun acc l -> + match Irmin.Type.of_string Entry.t l with + | Ok x -> x :: acc + | Error (`Msg e) -> failwith e) + [] lines + |> fun l -> Ok l + with Failure e -> Error (`Msg e) + + let t = Irmin.Type.like ~pp:lines ~of_string t + let timestamp = function [] -> 0L | e :: _ -> Entry.timestamp e + + let newer_than timestamp file = + let rec aux acc = function + | [] -> List.rev acc + | h :: _ when Entry.timestamp h <= timestamp -> List.rev acc + | h :: t -> aux (h :: acc) t + in + aux [] file + + let compare_entry = Irmin.Type.(unstage (compare Entry.t)) + + let merge ~old t1 t2 = + let open Irmin.Merge.Infix in + old () >>=* fun old -> + let old = match old with None -> [] | Some o -> o in + let ts = timestamp old in + let t1 = newer_than ts t1 in + let t2 = newer_than ts t2 in + let t3 = List.sort compare_entry (List.rev_append t1 t2) in + Irmin.Merge.ok (List.rev_append t3 old) + + let merge = Irmin.Merge.(option (v t merge)) + let add t e = e :: t +end + +(* Build an Irmin store containing log files. *) +module Store = Irmin_git_unix.FS.KV (Log) + +(* Set-up the local configuration of the Git repository. *) +let config = Irmin_git.config ~bare:true Config.root + +(* Convenient alias for the info function for commit messages *) +let info = Irmin_git_unix.info +let log_file = [ "local"; "debug" ] + +let all_logs t = + let+ logs = Store.find t log_file in + match logs with None -> Log.empty | Some l -> l + +(** Persist a new entry in the log. Pretty inefficient as it reads/writes the + whole file every time. *) +let log t fmt = + Printf.ksprintf + (fun message -> + let* logs = all_logs t in + let logs = Log.add logs (Entry.v message) in + Store.set_exn t ~info:(info "Adding a new entry") log_file logs) + fmt + +let print_logs name t = + let+ logs = all_logs t in + Fmt.pr "-----------\n%s:\n-----------\n%a%!" name (Irmin.Type.pp Log.t) logs + +let main () = + Config.init (); + let* repo = Store.Repo.v config in + let* t = Store.main repo in + + (* populate the log with some random messages *) + let* () = + Lwt_list.iter_s + (fun msg -> log t "This is my %s " msg) + [ "first"; "second"; "third" ] + in + Printf.printf "%s\n\n" what; + let* () = print_logs "lca" t in + let* x = Store.clone ~src:t ~dst:"test" in + let* () = log x "Adding new stuff to x" in + let* () = log x "Adding more stuff to x" in + let* () = log x "More. Stuff. To x." in + let* () = print_logs "branch 1" x in + let* () = log t "I can add stuff on t also" in + let* () = log t "Yes. On t!" in + let* () = print_logs "branch 2" t in + let* r = Store.merge_into ~info:(info "Merging x into t") x ~into:t in + match r with Ok () -> print_logs "merge" t | Error _ -> failwith "conflict!" + +let () = Lwt_main.run (main ()) diff --git a/vendors/irmin/examples/deploy.ml b/vendors/irmin/examples/deploy.ml new file mode 100644 index 0000000000000000000000000000000000000000..384db9c071e54d203eb7f32ddb4327dd5be1881f --- /dev/null +++ b/vendors/irmin/examples/deploy.ml @@ -0,0 +1,142 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) +open Lwt.Syntax +module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) + +let config = + let head = Git.Reference.v "refs/heads/upstream" in + Irmin_git.config ~head ~bare:false Config.root + +let info ~user message () = + let date = Int64.of_float (Unix.gettimeofday ()) in + let author = user in + Store.Info.v ~author ~message date + +(* 1. Cloning the gold image. *) +let provision repo = + Config.init (); + let provision = info ~user:"Automatic VM provisioning" in + let* t = Store.of_branch repo "upstream" in + let v = + Store.Tree.singleton [ "etc"; "manpath" ] + "/usr/share/man\n/usr/local/share/man" + in + let* v = + Store.Tree.add v [ "bin"; "sh" ] + "�����XpN ������� H__PAGEZERO(__TEXT__text__TEXT [...]" + in + Store.set_tree_exn t ~info:(provision "Cloning Ubuntu 14.04 Gold Image.") [] v + +(* 2. VM configuration. *) +let sysadmin = info ~user:"Bob the sysadmin" + +let configure repo = + let* t = Store.of_branch repo "upstream" in + let* () = Lwt_unix.sleep 2. in + let* t = Store.clone ~src:t ~dst:"dev" in + let* () = Lwt_unix.sleep 2. in + let* () = + Store.set_exn t + ~info:(sysadmin "DNS configuration") + [ "etc"; "resolv.conf" ] "domain mydomain.com\nnameserver 128.221.130.23" + in + let* () = Lwt_unix.sleep 2. in + let+ _ = Store.clone ~src:t ~dst:"prod" in + () + +let attack repo = + let info = info ~user:"Remote connection from 132.443.12.444" in + (* 3. Attacker. *) + let* t = Store.of_branch repo "prod" in + let* () = Lwt_unix.sleep 2. in + let* () = + Store.set_exn t + ~info:(info "$ vim /etc/resolv.conf") + [ "etc"; "resolv.conf" ] "domain mydomain.com\nnameserver 12.221.130.23" + in + let* () = Lwt_unix.sleep 2. in + Store.set_exn t + ~info:(info "$ gcc -c /tmp/sh.c -o /bin/sh") + [ "bin"; "sh" ] "�����XpNx ������� H__PAGEZERO(__TEXT__text__TEXT [...]" + +let revert repo = + let* prod = Store.of_branch repo "prod" in + let* dev = Store.of_branch repo "dev" in + let* h1 = Store.Head.get prod in + let* h2 = Store.Head.get dev in + if h1 <> h2 then ( + Printf.printf + "WARNING: the filesystem is different in dev and prod, intrusion detected!\n\ + Reverting the production system to the dev environment.\n\ + %!"; + let* () = Lwt_unix.sleep 2. in + Store.Head.set prod h2) + else Lwt.return_unit + +let () = + let cmd = Sys.argv.(0) in + let help () = + Printf.eprintf + "This demo models a simple deployment scenario in three phases:\n\n\ + \ - [%s provision] first a VM is provisioned;\n\ + \ - [%s configure] then a sysadmin connects to the machine \n\ + \ and install some software packages;\n\ + \ - [%s attack] an attacker connects to the machine and \n\ + \ injects random code.\n\ + \ - [%s revert] the sysadmin revert the VM in a consistent state.\n\n\ + Run `irmin init -d --root=%s` and Connect your browser \n\ + to http://127.0.0.1:8080/graph to see the system state evolving in \n\ + real-time during the different phases.\n\n\ + Using a VCS-style filesystem allows file modifications to be tracked, \ + with \n\ + user origin and dates. It also supports quickly reverting to a \ + consistent \n\ + state when needed.\n" + cmd cmd cmd cmd Config.root + in + if Array.length Sys.argv <> 2 then help () + else + match Sys.argv.(1) with + | "provision" -> + Lwt_main.run + (let* repo = Store.Repo.v config in + provision repo); + Printf.printf + "The VM is now provisioned. Run `%s configure` to simulate a sysadmin \n\ + configuration.\n" + cmd + | "configure" -> + Lwt_main.run + (let* repo = Store.Repo.v config in + configure repo); + Printf.printf + "The VM is now configured. Run `%s attack` to simulate an attack by \ + an \n\ + intruder.\n" + cmd + | "attack" -> + Lwt_main.run + (let* repo = Store.Repo.v config in + attack repo); + Printf.printf + "The VM has been attacked. Run `%s revert` to revert the VM state to \ + a safe one.\n" + cmd + | "revert" -> + Lwt_main.run + (let* repo = Store.Repo.v config in + revert repo) + | _ -> help () diff --git a/vendors/irmin/examples/dune b/vendors/irmin/examples/dune new file mode 100644 index 0000000000000000000000000000000000000000..69143887ad13287c874dba951bc11cb0de5d9915 --- /dev/null +++ b/vendors/irmin/examples/dune @@ -0,0 +1,51 @@ +(executables + (names + readme + trees + sync + process + deploy + irmin_git_store + custom_merge + push + custom_graphql + fold) + (libraries + astring + cohttp + fmt + irmin.unix + irmin-git.unix + irmin-graphql.unix + lwt + lwt.unix) + (preprocess + (pps ppx_irmin))) + +(alias + (name examples) + (deps + readme.exe + trees.exe + sync.exe + process.exe + deploy.exe + push.exe + irmin_git_store.exe + custom_merge.exe + custom_graphql.exe + fold.exe)) + +(alias + (name runtest) + (package irmin-git) + (deps + readme.exe + trees.exe + sync.exe + process.exe + deploy.exe + push.exe + irmin_git_store.exe + custom_merge.exe + fold.exe)) diff --git a/vendors/irmin/examples/fold.ml b/vendors/irmin/examples/fold.ml new file mode 100644 index 0000000000000000000000000000000000000000..152c9854451228861147401abfbb0c23c4d34929 --- /dev/null +++ b/vendors/irmin/examples/fold.ml @@ -0,0 +1,100 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* example of using tree fold *) + +open Lwt.Syntax +module Store = Irmin_mem.KV.Make (Irmin.Contents.String) +module Tree = Store.Tree + +let config = Irmin_mem.config () + +let info = + let counter = ref 0L in + let inc () = + let c = !counter in + counter := Int64.add c 1L; + c + in + fun message () -> Store.Info.v ~author:"fold.exe" ~message (inc ()) + +module Folder : sig + (* Not accumulating anything so use unit as accumulator type *) + val pre : (unit, Store.step list) Tree.folder + val post : (unit, Store.step list) Tree.folder + val node : (unit, Store.node) Tree.folder + val contents : (unit, Store.contents) Tree.folder + val tree : (unit, Store.tree) Tree.folder +end = struct + let print_path newline path _ _ = + let format : ('a, Format.formatter, unit) format = + "Visit [%s]" ^^ if newline then "\n" else "" + in + Fmt.(pf stdout format (String.concat ";" path)) |> Lwt.return + + let pre = print_path true + let post = print_path true + let node = print_path true + + let contents path c acc = + let* () = print_path false path c acc in + Fmt.(pf stdout " = '%s'\n" c) |> Lwt.return + + let tree path t acc = + let* () = print_path false path t acc in + let* k = Tree.kind t [] in + match k with + | Some k' -> + (match k' with + | `Node -> Fmt.(string stdout ", with `Node kind\n") + | `Contents -> Fmt.(string stdout ", with `Contents kind\n")) + |> Lwt.return + | None -> failwith "no kind" +end + +let main = + let ps name = Fmt.(pf stdout "\n%s\n" name) in + ps "Demo of how tree folders visit nodes."; + let* repo = Store.Repo.v config in + let* main_b = Store.main repo in + let* () = Store.set_exn ~info:(info "add c1") main_b [ "c1" ] "c1" in + let* () = Store.set_exn ~info:(info "add c2") main_b [ "c2" ] "c2" in + let* () = + Store.set_exn ~info:(info "add n1/c1") main_b [ "n1"; "c1" ] "n1/c1" + in + let* () = + Store.set_exn ~info:(info "add n1/n1/c1") main_b [ "n1"; "n1"; "c1" ] + "n1/n1/c1" + in + let* () = + Store.set_exn ~info:(info "add n2/c1") main_b [ "n2"; "c1" ] "n2/c1" + in + let* t = Store.tree main_b in + (* let order = `Random (Random.State.make_self_init ()) in *) + let order = `Sorted in + ps "pre folder: preorder traversal of `Node kinds"; + let* () = Tree.fold ~order ~pre:Folder.pre t () in + ps "post folder: postorder traversal of `Node kinds"; + let* () = Tree.fold ~order ~post:Folder.post t () in + ps "node folder: visit all `Node kinds"; + let* () = Tree.fold ~order ~node:Folder.node t () in + ps "contents folder: visit all `Contents kinds"; + let* () = Tree.fold ~order ~contents:Folder.contents t () in + ps "tree folder: visit both `Node and `Contents kinds"; + let* () = Tree.fold ~order ~tree:Folder.tree t () in + Lwt.return_unit + +let () = Lwt_main.run main diff --git a/vendors/irmin/examples/irmin_git_store.ml b/vendors/irmin/examples/irmin_git_store.ml new file mode 100644 index 0000000000000000000000000000000000000000..965042953452bc08ea23c05c34f9077d84a16482 --- /dev/null +++ b/vendors/irmin/examples/irmin_git_store.ml @@ -0,0 +1,65 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Simple example of reading and writing in a Git repository *) + +open Lwt.Syntax + +let info = Irmin_git_unix.info + +module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) + +let update t k v = + let msg = Fmt.str "Updating /%s" (String.concat "/" k) in + print_endline msg; + Store.set_exn t ~info:(info "%s" msg) k v + +let read_exn t k = + let msg = Fmt.str "Reading /%s" (String.concat "/" k) in + print_endline msg; + Store.get t k + +let main () = + Config.init (); + let config = Irmin_git.config ~bare:true Config.root in + let* repo = Store.Repo.v config in + let* t = Store.main repo in + let* () = update t [ "root"; "misc"; "1.txt" ] "Hello world!" in + let* () = update t [ "root"; "misc"; "2.txt" ] "Hi!" in + let* () = update t [ "root"; "misc"; "3.txt" ] "How are you ?" in + let* _ = read_exn t [ "root"; "misc"; "2.txt" ] in + let* x = Store.clone ~src:t ~dst:"test" in + print_endline "cloning ..."; + let* () = update t [ "root"; "misc"; "3.txt" ] "Hohoho" in + let* () = update x [ "root"; "misc"; "2.txt" ] "Cool!" in + let* r = Store.merge_into ~info:(info "t: Merge with 'x'") x ~into:t in + match r with + | Error _ -> failwith "conflict!" + | Ok () -> + print_endline "merging ..."; + let* _ = read_exn t [ "root"; "misc"; "2.txt" ] in + let+ _ = read_exn t [ "root"; "misc"; "3.txt" ] in + () + +let () = + Printf.printf + "This example creates a Git repository in %s and use it to read \n\ + and write data:\n" + Config.root; + let _ = Sys.command (Printf.sprintf "rm -rf %s" Config.root) in + Lwt_main.run (main ()); + Printf.printf "You can now run `cd %s && tig` to inspect the store.\n" + Config.root diff --git a/vendors/irmin/examples/plugin/README.md b/vendors/irmin/examples/plugin/README.md new file mode 100644 index 0000000000000000000000000000000000000000..016a11d4ffaa78e372fce08c365ed3421ec5314c --- /dev/null +++ b/vendors/irmin/examples/plugin/README.md @@ -0,0 +1,33 @@ +# Example plugin + +## Building + +From the root of the irmin repository: + +```sh +$ dune build ./examples/plugin/plugin.cmxs +``` + +## Usage + +To load this plugin you can use the `--plugin` flag when using `irmin` (or +`dune exec ./src/irmin-cli/bin/main.exe` from the root of the irmin repo): + +```sh +$ dune exec ./src/irmin-cli/bin/main.exe -- set --plugin _build/default/examples/plugin/plugin.cmxs a/b/c 123 +``` + +By default this will use the `mem-int` store defined in [plugin.ml](https://github.com/mirage/irmin/blob/main/examples/plugin/plugin.ml) +since the `default` parameter is `true` when calling `Irmin_cli.Resolver.Store.add`. + +It is still possible to select the store and content type after a plugin has +been loaded. To use the `int` content type with a git store you can run: + +```sh +$ echo 'plugin: _build/default/examples/plugin/plugin.cmxs' > irmin.yml # Set the plugin in config file +$ dune exec ./src/irmin-cli/bin/main.exe -- set --root /tmp/irmin-plugin -s git -c int a/b/c 123 +``` + +Since the `default` parameter is `true` when registering the content type using +`Irmin_cli.Resolver.Contents.add`, `int` contents will already be the default, +which means `-c int` could be left out. diff --git a/vendors/irmin/examples/plugin/dune b/vendors/irmin/examples/plugin/dune new file mode 100644 index 0000000000000000000000000000000000000000..d729afa5505d7cd32f831659a7b10b03b484e132 --- /dev/null +++ b/vendors/irmin/examples/plugin/dune @@ -0,0 +1,14 @@ +(executable + (name plugin) + (modes plugin) + (modules plugin) + (libraries irmin-cli)) + +(alias + (name runtest) + (package irmin-cli) + (deps plugin.cmxs)) + +(cram + (package irmin-cli) + (deps %{bin:irmin} plugin.cmxs)) diff --git a/vendors/irmin/examples/plugin/plugin.ml b/vendors/irmin/examples/plugin/plugin.ml new file mode 100644 index 0000000000000000000000000000000000000000..05b7cff8664e32a430ff5468ae01c5475df392f6 --- /dev/null +++ b/vendors/irmin/examples/plugin/plugin.ml @@ -0,0 +1,28 @@ +open Irmin_cli + +(* Adding a new content type *) + +module Int = struct + type t = int + + let t = Irmin.Type.int + let merge = Irmin.Merge.(option (idempotent t)) +end + +let () = Resolver.Contents.add ~default:true "int" (module Int) + +module Schema = struct + module Contents = Int + module Hash = Irmin.Hash.BLAKE2B + module Branch = Irmin.Branch.String + module Path = Irmin.Path.String_list + module Info = Irmin.Info.Default + module Metadata = Irmin.Metadata.None +end + +(* Adding a new store type *) + +module Store = Irmin_mem.Make (Schema) + +let store = Resolver.Store.v Irmin_mem.Conf.spec (module Store) +let () = Resolver.Store.add ~default:true "mem-int" (Fixed store) diff --git a/vendors/irmin/examples/plugin/plugin.t b/vendors/irmin/examples/plugin/plugin.t new file mode 100644 index 0000000000000000000000000000000000000000..66ddb4aee56f01488fef6093db5af64a77d2b478 --- /dev/null +++ b/vendors/irmin/examples/plugin/plugin.t @@ -0,0 +1,9 @@ + $ irmin set --plugin ./plugin.cmxs a/b/c 123 + $ echo 'plugin: plugin.cmxs' > irmin.yml # Set the plugin in config file + $ irmin set --root ./irmin-plugin -s git -c int a/b/c 123 + $ irmin get --root ./irmin-plugin -s git -c int a/b/c + 123 + $ irmin set --root ./irmin-plugin -s git -c int a/b/c "AAA" + ERROR: int_of_string + [1] + diff --git a/vendors/irmin/examples/process.ml b/vendors/irmin/examples/process.ml new file mode 100644 index 0000000000000000000000000000000000000000..04ce82b2352da7425217b7d2fd51256d1884c283 --- /dev/null +++ b/vendors/irmin/examples/process.ml @@ -0,0 +1,179 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Simple UI example: connect to http://localhost:8080/dump *) + +open Lwt.Syntax + +let fin () = + let _ = Fmt.kstr Sys.command "cd %s && git reset HEAD --hard" Config.root in + Lwt.return_unit + +type action = { + message : string; + files : (string list * (unit -> string)) list; +} + +type image = { name : string; actions : action list } + +let ubuntu = + { + name = "official-images/ubuntu:14.04"; + actions = + [ + { + message = "Updating source lists"; + files = + [ + ( [ "etc"; "source.list" ], + fun () -> Fmt.str "deb %d" (Random.int 10) ); + ]; + }; + { message = "grep -v '^#' /etc/apt/sources.list"; files = [] }; + { message = "cat /etc/issue"; files = [] }; + ]; + } + +let wordpress = + { + name = "official-images/wordpress:latest"; + actions = + [ + { + message = "user logging"; + files = + [ + ( [ "wordpress"; "wp-users.php" ], + fun () -> Fmt.str " Fmt.str " Fmt.str "X%duYYt" (Random.int 10) ); + ]; + }; + { message = "Reading table wp_posts"; files = [] }; + { + message = "Writing table wp_posts"; + files = + [ + ( [ "var"; "lib"; "mysql" ], + fun () -> Fmt.str "X%dxYYt" (Random.int 10) ); + ]; + }; + ]; + } + +let branch image = String.map (function ':' -> '/' | c -> c) image.name +let images = [| (*ubuntu; *) wordpress; mysql |] + +module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) + +let head = Git.Reference.v ("refs/heads/" ^ branch images.(0)) +let config = Irmin_git.config ~bare:true ~head Config.root + +let info image message () = + let date = Int64.of_float (Unix.gettimeofday ()) in + let author = image.name in + Store.Info.v ~author ~message date + +let main = branch images.(0) + +let init () = + Config.init (); + let* repo = Store.Repo.v config in + let* t = Store.of_branch repo main in + let* () = Store.set_exn t ~info:(info images.(0) "init") [ "0" ] "0" in + Lwt_list.iter_s + (fun i -> + let* _ = Store.clone ~src:t ~dst:(branch i) in + Lwt.return_unit) + (Array.to_list images) + +let random_array a = a.(Random.int (Array.length a)) +let random_list l = random_array (Array.of_list l) + +let rec process image = + let id = branch image in + Printf.printf "Processing %s\n%!" id; + let actions = random_list image.actions in + let key, value = + try random_list actions.files + with _ -> + ([ "log"; id; "0" ], fun () -> id ^ string_of_int (Random.int 10)) + in + let* repo = Store.Repo.v config in + let* t = Store.of_branch repo id in + let* () = Store.set_exn t ~info:(info image actions.message) key (value ()) in + let* () = + if Random.int 3 = 0 then + let branch = branch (random_array images) in + if branch <> id then ( + Printf.printf "Merging ...%!"; + let* r = + Store.merge_with_branch t + ~info:(info image @@ Fmt.str "Merging with %s" branch) + branch + in + match r with + | Ok () -> + Printf.printf "ok!\n%!"; + Lwt.return_unit + | Error _ -> Lwt.fail_with "conflict!") + else Lwt.return_unit + else Lwt.return_unit + in + let* () = Lwt_unix.sleep (max 0.1 (Random.float 0.3)) in + process image + +let rec protect fn x = + Lwt.catch + (fun () -> fn x) + (fun e -> + Printf.eprintf "error: %s" (Printexc.to_string e); + protect fn x) + +let rec watchdog () = + Printf.printf "I'm alive!\n%!"; + let* () = Lwt_unix.sleep 1. in + watchdog () + +let () = + let aux () = + let* () = init () in + Lwt.choose (watchdog () :: List.map (protect process) (Array.to_list images)) + in + Lwt_main.run (aux ()) diff --git a/vendors/irmin/examples/push.ml b/vendors/irmin/examples/push.ml new file mode 100644 index 0000000000000000000000000000000000000000..68c9252de6badbdb5d35ed17914be6edb88a1a73 --- /dev/null +++ b/vendors/irmin/examples/push.ml @@ -0,0 +1,54 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Simple example of Git push *) + +open Lwt.Syntax + +let info = Irmin_git_unix.info + +let url, user, token = + if Array.length Sys.argv = 4 then (Sys.argv.(1), Sys.argv.(2), Sys.argv.(3)) + else failwith "usage: push.exe url user token" + +module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) +module Sync = Irmin.Sync.Make (Store) + +let headers = + let e = Cohttp.Header.of_list [] in + Cohttp.Header.add_authorization e (`Basic (user, token)) + +let test () = + Config.init (); + let config = Irmin_git.config Config.root in + let* repo = Store.Repo.v config in + let* t = Store.main repo in + let* remote = Store.remote ~headers url in + let* _ = Sync.pull_exn t remote `Set in + let* readme = Store.get t [ "README.md" ] in + let* tree = Store.get_tree t [] in + let* tree = Store.Tree.add tree [ "BAR.md" ] "Hoho!" in + let* tree = Store.Tree.add tree [ "FOO.md" ] "Hihi!" in + let* () = Store.set_tree_exn t ~info:(info "merge") [] tree in + Printf.printf "%s\n%!" readme; + let* bar = Store.get t [ "BAR.md" ] in + Printf.printf "%s\n%!" bar; + let* foo = Store.get t [ "FOO.md" ] in + Printf.printf "%s\n%!" foo; + let+ _ = Sync.push_exn t remote in + () + +let () = Lwt_main.run (test ()) diff --git a/vendors/irmin/examples/readme.ml b/vendors/irmin/examples/readme.ml new file mode 100644 index 0000000000000000000000000000000000000000..e8c0f33a21551261774f3a1d25b2ed2c72b08294 --- /dev/null +++ b/vendors/irmin/examples/readme.ml @@ -0,0 +1,33 @@ +open Lwt.Syntax + +(* Irmin store with string contents *) +module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) + +(* Database configuration *) +let config = Irmin_git.config ~bare:true "/tmp/irmin/test" + +(* Commit author *) +let author = "Example " + +(* Commit information *) +let info fmt = Irmin_git_unix.info ~author fmt + +let main = + (* Open the repo *) + let* repo = Store.Repo.v config in + + (* Load the main branch *) + let* t = Store.main repo in + + (* Set key "foo/bar" to "testing 123" *) + let* () = + Store.set_exn t ~info:(info "Updating foo/bar") [ "foo"; "bar" ] + "testing 123" + in + + (* Get key "foo/bar" and print it to stdout *) + let+ x = Store.get t [ "foo"; "bar" ] in + Printf.printf "foo/bar => '%s'\n" x + +(* Run the program *) +let () = Lwt_main.run main diff --git a/vendors/irmin/examples/sync.ml b/vendors/irmin/examples/sync.ml new file mode 100644 index 0000000000000000000000000000000000000000..4f206b02cc7e0b44d68084c34766436335ed4d37 --- /dev/null +++ b/vendors/irmin/examples/sync.ml @@ -0,0 +1,42 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt.Syntax + +let info = Irmin_git_unix.info + +let path = + if Array.length Sys.argv = 2 then Sys.argv.(1) + else "git://github.com/mirage/ocaml-git.git" + +module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) +module Sync = Irmin.Sync.Make (Store) + +let test () = + Config.init (); + let config = Irmin_git.config Config.root in + let* repo = Store.Repo.v config in + let* t = Store.of_branch repo "master" in + let* upstream = Store.remote path in + let* _ = Sync.pull_exn t upstream `Set in + let* readme = Store.get t [ "README.md" ] in + let* tree = Store.get_tree t [] in + let* tree = Store.Tree.add tree [ "BAR.md" ] "Hoho!" in + let* tree = Store.Tree.add tree [ "FOO.md" ] "Hihi!" in + let+ () = Store.set_tree_exn t ~info:(info "merge") [] tree in + Printf.printf "%s\n%!" readme + +let () = Lwt_main.run (test ()) diff --git a/vendors/irmin/examples/trees.ml b/vendors/irmin/examples/trees.ml new file mode 100644 index 0000000000000000000000000000000000000000..07a1a2bad50c447e2053b852a95e2e2550ed677e --- /dev/null +++ b/vendors/irmin/examples/trees.ml @@ -0,0 +1,71 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* example of using the tree API *) + +open Lwt.Syntax +module Store = Irmin_git_unix.FS.KV (Irmin.Contents.String) +module Tree = Store.Tree + +let info = Irmin_git_unix.info + +type t1 = int +type t2 = { x : string; y : t1 } +type t = t2 list + +let tree_of_t t = + let+ tree, _ = + Lwt_list.fold_left_s + (fun (v, i) t2 -> + let si = string_of_int i in + let* v = Tree.add v [ si; "x" ] t2.x in + let+ v = Tree.add v [ si; "y" ] (string_of_int t2.y) in + (v, i + 1)) + (Tree.empty (), 0) + t + in + tree + +let t_of_tree v = + let aux acc i = + let i = string_of_int i in + let* x = Tree.get v [ i; "x" ] in + let+ y = Tree.get v [ i; "y" ] in + { x; y = int_of_string y } :: acc + in + let* t2s = Tree.list v [] in + let t2s = List.map (fun (i, _) -> int_of_string i) t2s in + let t2s = List.rev (List.sort compare t2s) in + Lwt_list.fold_left_s aux [] t2s + +let main () = + Config.init (); + let config = Irmin_git.config ~bare:false Config.root in + let t = + [ { x = "foo"; y = 3 }; { x = "bar"; y = 5 }; { x = "too"; y = 10 } ] + in + let* v = tree_of_t t in + let* repo = Store.Repo.v config in + let* t = Store.main repo in + let* () = Store.set_tree_exn t ~info:(info "update a/b") [ "a"; "b" ] v in + let* v = Store.get_tree t [ "a"; "b" ] in + let* tt = t_of_tree v in + let* () = Store.set_tree_exn t ~info:(info "update a/c") [ "a"; "c" ] v in + let tt = tt @ [ { x = "ggg"; y = 4 } ] in + let* vv = tree_of_t tt in + Store.set_tree_exn t ~info:(info "merge tree into a/b") [ "a"; "b" ] vv + +let () = Lwt_main.run (main ()) diff --git a/vendors/irmin/irmin-bench.opam b/vendors/irmin/irmin-bench.opam new file mode 100644 index 0000000000000000000000000000000000000000..f6276723860112de7308bfeb8578ae33dab9126f --- /dev/null +++ b/vendors/irmin/irmin-bench.opam @@ -0,0 +1,50 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] +] + +depends: [ + "dune" {>= "2.9.0"} + "irmin-pack" {= version} + "irmin-test" {= version} + "irmin-tezos" {= version} + "cmdliner" + "logs" + "lwt" {>= "5.3.0"} + "repr" {>= "0.3.0"} + "ppx_repr" + "re" {>= "1.9.0"} + "fmt" + "uuidm" + "progress" {>="0.2.1"} + "fpath" {with-test} + "bentov" + "mtime" + "ppx_deriving" + "alcotest" {with-test} + "rusage" + "uutf" + "uucp" + "printbox" {>= "0.6"} + "printbox-text" +] + +available: [ + # Disabled on 32-bit platforms due to an overly-large int literal in the source + arch != "arm32" & arch != "x86_32" +] + +synopsis: "Irmin benchmarking suite" +description: """ +`irmin-bench` provides access to the Irmin suite for benchmarking storage backend +implementations. +""" diff --git a/vendors/irmin/irmin-chunk.opam b/vendors/irmin/irmin-chunk.opam new file mode 100644 index 0000000000000000000000000000000000000000..63812ee2a1e899a4b0e2e35a9ca74c24bbea61e7 --- /dev/null +++ b/vendors/irmin/irmin-chunk.opam @@ -0,0 +1,26 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Mounir Nasr Allah" "Thomas Gazagnaire"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.02.3"} + "dune" {>= "2.9.0"} + "irmin" {= version} + "fmt" + "logs" + "lwt" {>= "5.3.0"} + "irmin-test" {with-test & = version} + "alcotest" {with-test} +] + +synopsis: "Irmin backend which allow to store values into chunks" diff --git a/vendors/irmin/irmin-cli.opam b/vendors/irmin/irmin-cli.opam new file mode 100644 index 0000000000000000000000000000000000000000..e610159428736f13635980234af73ed101cdb70f --- /dev/null +++ b/vendors/irmin/irmin-cli.opam @@ -0,0 +1,56 @@ +opam-version: "2.0" +maintainer: "Tarides " +authors: ["Tarides"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +available: arch != "arm32" & arch != "x86_32" + +depends: [ + "ocaml" {>= "4.01.0"} + "dune" {>= "2.9.0"} + "irmin" {= version} + "irmin-git" {= version} + "irmin-http" {= version} + "irmin-fs" {= version} + "irmin-pack" {= version} + "irmin-graphql" {= version} + "irmin-tezos" {= version} + "git-unix" {>= "3.7.0"} + "digestif" {>= "0.9.0"} + "irmin-watcher" {>= "0.2.0"} + "yaml" {>= "3.0.0"} + "astring" + "astring" + "cohttp" + "cohttp-lwt" + "cohttp-lwt-unix" + "conduit" + "conduit-lwt" + "conduit-lwt-unix" + "logs" + "uri" + "cmdliner" + "cohttp-lwt-unix" + "fmt" + "git" {>= "3.7.0"} + "happy-eyeballs-lwt" + "lwt" {>= "5.3.0"} + "irmin-test" {with-test & = version} + "alcotest" {with-test} + "mdx" {>= "2.0.0" & with-test} +] + +synopsis: "CLI for Irmin" +description: """ +A simple CLI tool (called `irmin`) to manipulate and inspect Irmin stores. +""" diff --git a/vendors/irmin/irmin-containers.opam b/vendors/irmin/irmin-containers.opam new file mode 100644 index 0000000000000000000000000000000000000000..f907ec7eb52ce603d27cdab33256b8a6f56e7c40 --- /dev/null +++ b/vendors/irmin/irmin-containers.opam @@ -0,0 +1,33 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["KC Sivaramakrishnan" "Anirudh Sunder Raj"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.03.0"} + "dune" {>= "2.9.0"} + "irmin" {= version} + "irmin-fs" {= version} + "ppx_irmin" {= version} + "lwt" {>= "5.3.0"} + "mtime" + "alcotest" {with-test} + "alcotest-lwt" {with-test} +] + +synopsis: "Mergeable Irmin data structures" +description: """ +A collection of simple, ready-to-use mergeable data structures built using +Irmin. Each data structure works with an arbitrary Irmin backend and is +customisable in a variety of ways. +""" diff --git a/vendors/irmin/irmin-fs.opam b/vendors/irmin/irmin-fs.opam new file mode 100644 index 0000000000000000000000000000000000000000..e88d8f9070fe3d888b1c9804bc7d31204578438b --- /dev/null +++ b/vendors/irmin/irmin-fs.opam @@ -0,0 +1,28 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.03.0"} + "dune" {>= "2.9.0"} + "irmin" {= version} + "astring" + "logs" + "lwt" {>= "5.3.0"} + "alcotest" {with-test} + "irmin-test" {with-test & = version} + "irmin-watcher" {with-test & >= "0.2.0"} +] + +synopsis: "Generic file-system backend for Irmin" diff --git a/vendors/irmin/irmin-git.opam b/vendors/irmin/irmin-git.opam new file mode 100644 index 0000000000000000000000000000000000000000..7b7df9b67b60ed453547e4e1fb8932f8d4875905 --- /dev/null +++ b/vendors/irmin/irmin-git.opam @@ -0,0 +1,44 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + # Tests disabled on 32-bit platforms as the Dune build fails in CI: + ["dune" "runtest" "-p" name "-j" jobs] {with-test & arch != "arm32" & arch != "x86_32"} +] + +depends: [ + "ocaml" {>= "4.02.3"} + "dune" {>= "2.9.0"} + "irmin" {= version} + "ppx_irmin" {= version} + "git" {>= "3.7.0"} + "git-unix" {>= "3.7.0"} + "digestif" {>= "0.9.0"} + "cstruct" + "fmt" + "astring" + "cohttp-lwt-unix" + "fpath" + "logs" + "lwt" {>= "5.3.0"} + "uri" + "mimic" + "irmin-test" {with-test & = version} + "mtime" {with-test & >= "1.0.0"} + "alcotest" {with-test} +] +available: [ arch != "s390x" ] # temporary disable until ocaml-git works properly + +synopsis: "Git backend for Irmin" +description: """ +`Irmin_git` expose a bi-directional bridge between Git repositories and +Irmin stores. +""" diff --git a/vendors/irmin/irmin-graphql.opam b/vendors/irmin/irmin-graphql.opam new file mode 100644 index 0000000000000000000000000000000000000000..74eab28e916a53d61ce5954fb80b1d9a451cb091 --- /dev/null +++ b/vendors/irmin/irmin-graphql.opam @@ -0,0 +1,37 @@ +opam-version: "2.0" +maintainer: "Andreas Garnaes " +authors: "Andreas Garnaes " +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.03.0"} + "dune" {>= "2.9.0"} + "irmin" {= version} + "graphql" {>= "0.13.0"} + "graphql-lwt" {>= "0.13.0"} + "graphql-cohttp" {>= "0.13.0"} + "graphql_parser" {>= "0.13.0"} + "cohttp" + "cohttp-lwt" + "cohttp-lwt-unix" + "git-unix" {>= "3.7.0"} + "fmt" + "lwt" {>= "5.3.0"} + "alcotest-lwt" {with-test & >= "1.1.0"} + "yojson" {with-test} + "alcotest" {with-test & >= "1.2.3"} + "logs" {with-test} +] + + +synopsis: "GraphQL server for Irmin" diff --git a/vendors/irmin/irmin-http.opam b/vendors/irmin/irmin-http.opam new file mode 100644 index 0000000000000000000000000000000000000000..cdff5463b409240ab5bfca2e6765a235831768e8 --- /dev/null +++ b/vendors/irmin/irmin-http.opam @@ -0,0 +1,38 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.02.3"} + "dune" {>= "2.9.0"} + "crunch" {>= "2.2.0"} + "webmachine" {>= "0.6.0"} + "irmin" {= version} + "ppx_irmin" {= version} + "cohttp-lwt" {>= "1.0.0"} + "cohttp-lwt-unix" {>= "1.0.0"} + "astring" + "cohttp" + "fmt" + "jsonm" + "logs" + "lwt" {>= "5.3.0"} + "uri" + "irmin-git" {with-test & = version} + "irmin-test" {with-test & = version} + "git-unix" {with-test & >= "3.5.0"} + "digestif" {with-test & >= "0.9.0"} +] + +synopsis: "HTTP client and server for Irmin" diff --git a/vendors/irmin/irmin-mirage-git.opam b/vendors/irmin/irmin-mirage-git.opam new file mode 100644 index 0000000000000000000000000000000000000000..e7628416d202c95539394c99ecb1ce416369f1c7 --- /dev/null +++ b/vendors/irmin/irmin-mirage-git.opam @@ -0,0 +1,27 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: "Thomas Gazagnaire" +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] +] + +depends: [ + "dune" {>= "2.9.0"} + "irmin-mirage" {= version} + "irmin-git" {= version} + "mirage-kv" {>= "3.0.0"} + "fmt" + "git" {>= "3.7.0"} + "lwt" {>= "5.3.0"} + "mirage-clock" + "uri" +] + +synopsis: "MirageOS-compatible Irmin stores" diff --git a/vendors/irmin/irmin-mirage-graphql.opam b/vendors/irmin/irmin-mirage-graphql.opam new file mode 100644 index 0000000000000000000000000000000000000000..da6926a61806e70e0d7c7b100bd544a8bc4590bf --- /dev/null +++ b/vendors/irmin/irmin-mirage-graphql.opam @@ -0,0 +1,26 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: "Thomas Gazagnaire" +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] +] + +depends: [ + "dune" {>= "2.9.0"} + "irmin-mirage" {= version} + "irmin-graphql" {= version} + "mirage-clock" + "cohttp-lwt" + "lwt" {>= "5.3.0"} + "uri" + "git" {>= "3.4.0"} +] + +synopsis: "MirageOS-compatible Irmin stores" diff --git a/vendors/irmin/irmin-mirage.opam b/vendors/irmin/irmin-mirage.opam new file mode 100644 index 0000000000000000000000000000000000000000..710d97af26a8f83d0f800b567fec5231ddc99a05 --- /dev/null +++ b/vendors/irmin/irmin-mirage.opam @@ -0,0 +1,23 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: "Thomas Gazagnaire" +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] +] + +depends: [ + "dune" {>= "2.9.0"} + "irmin" {= version} + "fmt" + "ptime" + "mirage-clock" {>= "3.0.0"} +] + +synopsis: "MirageOS-compatible Irmin stores" diff --git a/vendors/irmin/irmin-pack.opam b/vendors/irmin/irmin-pack.opam new file mode 100644 index 0000000000000000000000000000000000000000..86aa72ffff849ce36a1b3d3993f551f3fa043b0a --- /dev/null +++ b/vendors/irmin/irmin-pack.opam @@ -0,0 +1,33 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.08.0"} + "dune" {>= "2.9.0"} + "irmin" {= version} + "ppx_irmin" {= version} + "index" {>= "1.6.0"} + "fmt" + "logs" + "lwt" {>= "5.3.0"} + "mtime" + "cmdliner" + "optint" {>= "0.1.0"} + "irmin-test" {with-test & = version} + "alcotest-lwt" {with-test} + "astring" {with-test} + "alcotest" {with-test} +] + +synopsis: "Irmin backend which stores values in a pack file" diff --git a/vendors/irmin/irmin-test.opam b/vendors/irmin/irmin-test.opam new file mode 100644 index 0000000000000000000000000000000000000000..bf35ef36c2ead11e289d1d5d43dec8dc2cece49e --- /dev/null +++ b/vendors/irmin/irmin-test.opam @@ -0,0 +1,39 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] +] + +depends: [ + "irmin" {= version} + "ppx_irmin" {= version} + "ocaml" {>= "4.02.3"} + "dune" {>= "2.9.0"} + "alcotest-lwt" {>= "1.5.0"} + "mtime" {>= "1.0.0"} + "astring" + "fmt" + "jsonm" + "logs" + "lwt" {>= "5.3.0"} + "metrics-unix" + "ocaml-syntax-shims" + "cmdliner" + "metrics" {>= "0.2.0"} + "hex" {with-test & >= "1.4.0"} + "vector" {with-test & >= "1.0.0"} +] + +synopsis: "Irmin test suite" +description: """ +`irmin-test` provides access to the Irmin test suite for testing storage backend +implementations. +""" diff --git a/vendors/irmin/irmin-tezos.opam b/vendors/irmin/irmin-tezos.opam new file mode 100644 index 0000000000000000000000000000000000000000..a3e16f82c2cdfa3f598e44a64672a4e2cde1c50e --- /dev/null +++ b/vendors/irmin/irmin-tezos.opam @@ -0,0 +1,28 @@ +opam-version: "2.0" +synopsis: "Irmin implementation of the Tezos context hash specification" +description: "Irmin implementation of the Tezos context hash specification" +maintainer: "Tarides " +authors: ["Thomas Gazagnaire "] +license: "MIT" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +depends: [ + "dune" {>= "2.9.0"} + "irmin" {>= version} + "irmin-pack" {= version} + "ppx_irmin" {= version} + "tezos-base58" + "digestif" {>= "0.7"} + "cmdliner" + "fmt" + "yojson" + "alcotest" {with-test} + "hex" {with-test & >= "1.4.0"} + "fpath" {with-test} + "irmin-test" {with-test & = version} +] +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs "@runtest" {with-test}] +] +dev-repo: "git+https://github.com/mirage/irmin.git" diff --git a/vendors/irmin/irmin.opam b/vendors/irmin/irmin.opam new file mode 100644 index 0000000000000000000000000000000000000000..54ca3a10b23d9a7d72b87a86a089494ffeb53850 --- /dev/null +++ b/vendors/irmin/irmin.opam @@ -0,0 +1,55 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.08.0"} + "dune" {>= "2.9.0"} + "repr" {>= "0.6.0"} + "fmt" {>= "0.8.0"} + "uri" {>= "1.3.12"} + "uutf" + "jsonm" {>= "1.0.0"} + "lwt" {>= "5.3.0"} + "digestif" {>= "0.9.0"} + "ocamlgraph" + "logs" {>= "0.5.0"} + "bheap" {>= "2.0.0"} + "astring" + "mtime" {>= "1.0.0"} + "bigstringaf" { >= "0.2.0" } + "ppx_irmin" {= version} + "irmin-watcher" {>= "0.2.0"} + "hex" {with-test} + "alcotest" {>= "1.1.0" & with-test} + "alcotest-lwt" {with-test} + "vector" {with-test} + "odoc" {(< "2.0.1" | > "2.0.2") & with-doc} # See https://github.com/ocaml/odoc/issues/793 + "bisect_ppx" {dev & >= "2.5.0"} +] + +conflicts: [ + "result" {< "1.5"} # Requires `Result = Stdlib.Result` +] + +synopsis: """ +Irmin, a distributed database that follows the same design principles as Git +""" +description: """ +Irmin is a library for persistent stores with built-in snapshot, +branching and reverting mechanisms. It is designed to use a large +variety of backends. Irmin is written in pure OCaml and does not +depend on external C stubs; it aims to run everywhere, from Linux, +to browsers and Xen unikernels. +""" diff --git a/vendors/irmin/libirmin.opam b/vendors/irmin/libirmin.opam new file mode 100644 index 0000000000000000000000000000000000000000..60a7a04c22a6118ab6e76fe1ac97ca4c3ec56c53 --- /dev/null +++ b/vendors/irmin/libirmin.opam @@ -0,0 +1,23 @@ +opam-version: "2.0" +synopsis: "C bindings for irmin" +description: "C bindings for irmin using Ctypes inverted stubs" +maintainer: ["zachshipko@gmail.com"] +authors: ["Zach Shipko"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +depends: [ + "dune" {>= "2.9"} + "ctypes" {>= "0.19"} + "ctypes-foreign" {>= "0.18"} + "irmin" {= version} + "irmin-cli" {= version} +] +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +dev-repo: "git+https://github.com/mirage/irmin.git" + +available: [ arch != "arm64" ] # disabled because of SEGFAULT diff --git a/vendors/irmin/logo.svg b/vendors/irmin/logo.svg new file mode 100644 index 0000000000000000000000000000000000000000..48d85bf88e77d8dfe4a21221ffebcd7f81a64476 --- /dev/null +++ b/vendors/irmin/logo.svg @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/vendors/irmin/ppx_irmin.opam b/vendors/irmin/ppx_irmin.opam new file mode 100644 index 0000000000000000000000000000000000000000..ed6b33542c7acadd94bbcd70c704a46922061e63 --- /dev/null +++ b/vendors/irmin/ppx_irmin.opam @@ -0,0 +1,25 @@ +opam-version: "2.0" +maintainer: "Craig Ferguson " +author: "Craig Ferguson " +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +license: "ISC" +dev-repo: "git+https://github.com/mirage/irmin.git" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.10.0"} + "dune" {>= "2.9.0"} + "ppx_repr" {>= "0.2.0"} + "ppxlib" {>= "0.12.0"} + "logs" {>= "0.5.0"} + "fmt" {with-test & >= "0.8.0"} + "bisect_ppx" {dev & >= "2.5.0"} +] + +synopsis: "PPX deriver for Irmin type representations" diff --git a/vendors/irmin/src/irmin-chunk/dune b/vendors/irmin/src/irmin-chunk/dune new file mode 100644 index 0000000000000000000000000000000000000000..0b16010d73d7b2276c10b09b81fbaed5320fdbda --- /dev/null +++ b/vendors/irmin/src/irmin-chunk/dune @@ -0,0 +1,8 @@ +(library + (name irmin_chunk) + (public_name irmin-chunk) + (libraries irmin fmt logs lwt) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-chunk/import.ml b/vendors/irmin/src/irmin-chunk/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..71053e21ba54118af9da1fc7b37d45eb620c46e2 --- /dev/null +++ b/vendors/irmin/src/irmin-chunk/import.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/src/irmin-chunk/irmin_chunk.ml b/vendors/irmin/src/irmin-chunk/irmin_chunk.ml new file mode 100644 index 0000000000000000000000000000000000000000..eb3a286086b568db203759078941efc9047aa8fe --- /dev/null +++ b/vendors/irmin/src/irmin-chunk/irmin_chunk.ml @@ -0,0 +1,259 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2015 Mounir Nasr Allah + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +let src = Logs.Src.create "irmin.chunk" ~doc:"Irmin chunks" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Conf = struct + include Irmin.Backend.Conf + + let spec = Spec.v "chunk" + + module Key = struct + let min_size = + key ~spec ~doc:"Minimal chunk size" "min-size" Irmin.Type.int 4000 + + let chunk_size = key ~spec ~doc:"Size of chunk" "size" Irmin.Type.int 4096 + + let chunk_type_t = + Irmin.Type.(enum "chunk_type" [ ("max", `Max); ("best-fit", `Best_fit) ]) + + let chunking = + key ~spec ~doc:"Chunking algorithm" "chunking" chunk_type_t `Best_fit + end +end + +let err_too_small ~min size = + Printf.ksprintf invalid_arg + "Chunks of %d bytes are too small. Size should at least be %d bytes." size + min + +let config ?size ?min_size ?(chunking = `Best_fit) config = + let min_size = + match min_size with None -> Conf.default Conf.Key.min_size | Some v -> v + in + let size = + match size with + | None -> Conf.default Conf.Key.chunk_size + | Some v -> if v < min_size then err_too_small ~min:min_size v else v + in + let add x y c = Conf.add c x y in + let cfg = + Conf.empty Conf.spec + |> add Conf.Key.min_size min_size + |> add Conf.Key.chunk_size size + |> add Conf.Key.chunking chunking + in + Conf.(verify (union cfg config)) + +module Chunk (H : Irmin.Hash.S) = struct + type v = Data of string | Index of H.t list + + let v_t = + let open Irmin.Type in + variant "chunk" (fun d i -> function + | Data data -> d data | Index index -> i index) + |~ case1 "Data" string (fun d -> Data d) + |~ case1 "Index" (list ~len:`Int16 H.t) (fun i -> Index i) + |> sealv + + type value = v + [@@deriving irmin ~size_of ~to_bin_string ~decode_bin ~encode_bin] + + type t = { len : int; v : v } + + let size_of_v t = + match size_of_value t with + | Some n -> n + | None -> String.length (value_to_bin_string t) + + let size_of_data_header = size_of_v (Data "") + let size_of_index_header = size_of_v (Index []) + + let of_string b = + let len = String.length b in + let pos_ref = ref 0 in + let v = decode_bin_value b pos_ref in + if !pos_ref = len then { len; v } + else Fmt.invalid_arg "invalid length: got %d, expecting %d" !pos_ref len + + let to_string t = + let buf = Bytes.make t.len '\000' in + let b = Buffer.create t.len in + encode_bin_value t.v (Buffer.add_string b); + let s = Buffer.contents b in + Bytes.blit_string s 0 buf 0 (String.length s); + Bytes.unsafe_to_string buf + + let t = Irmin.Type.(map string) of_string to_string +end + +module Content_addressable + (Make_append_only : Irmin.Append_only.Maker) + (H : Irmin.Hash.S) + (V : Irmin.Type.S) = +struct + module Chunk = Chunk (H) + module AO = Make_append_only (H) (Chunk) + module CA = Irmin.Content_addressable.Make (Make_append_only) (H) (Chunk) + + type key = H.t [@@deriving irmin ~pp ~equal] + type value = V.t [@@deriving irmin ~of_bin_string ~to_bin_string ~pre_hash] + + type 'a t = { + chunking : [ `Max | `Best_fit ]; + db : 'a CA.t; + (* An handler to the underlying database. *) + chunk_size : int; + (* the size of chunks. *) + max_children : int; + (* the maximum number of children a node can have. *) + max_data : int; + (* the maximum length (in bytes) of data stored in one + chunk. *) + } + + let index t i = + let v = Chunk.Index i in + match t.chunking with + | `Max -> { Chunk.v; len = t.chunk_size } + | `Best_fit -> { Chunk.v; len = Chunk.size_of_v v } + + let data t s = + let v = Chunk.Data s in + match t.chunking with + | `Max -> { Chunk.v; len = t.chunk_size } + | `Best_fit -> { Chunk.v; len = Chunk.size_of_v v } + + module Tree = struct + (* return all the tree leaves *) + let find_leaves t root = + let rec aux acc { Chunk.v; _ } = + match v with + | Chunk.Data d -> Lwt.return (d :: acc) + | Chunk.Index i -> + Lwt_list.fold_left_s + (fun acc key -> + CA.find t.db key >>= function + | None -> Lwt.return acc + | Some v -> aux acc v) + acc i + in + aux [] root >|= List.rev + + (* partition a list into a list of elements of at most size [n] *) + let list_partition n l = + let rec aux done_ i acc = function + | [] -> List.rev (List.rev acc :: done_) + | h :: t -> + if i >= n then aux (List.rev acc :: done_) 1 [ h ] t + else aux done_ (i + 1) (h :: acc) t + in + aux [] 0 [] l + + let add t ~key l = + let rec aux = function + | [] -> invalid_arg "Irmin_chunk.Tree.add" + | [ k ] -> Lwt.return k + | l -> ( + let n = + if List.length l >= t.max_children then t.max_children + else List.length l + in + match list_partition n l with + | [ i ] -> AO.add t.db key (index t i) >|= fun () -> key + | l -> Lwt_list.map_p (fun i -> CA.add t.db (index t i)) l >>= aux) + in + aux l + end + + let v config = + let chunk_size = Conf.get config Conf.Key.chunk_size in + let max_data = chunk_size - Chunk.size_of_data_header in + let max_children = + (chunk_size - Chunk.size_of_index_header) / H.hash_size + in + let chunking = Conf.get config Conf.Key.chunking in + (if max_children <= 1 then + let min = Chunk.size_of_index_header + (H.hash_size * 2) in + err_too_small ~min chunk_size); + [%log.debug + "config: chunk-size=%d digest-size=%d max-data=%d max-children=%d" + chunk_size H.hash_size max_data max_children]; + let+ db = CA.v config in + { chunking; db; chunk_size; max_children; max_data } + + let close _ = Lwt.return_unit + let batch t f = CA.batch t.db (fun db -> f { t with db }) + + let find_leaves t key = + AO.find t.db key >>= function + | None -> Lwt.return_none (* shallow objects *) + | Some x -> Tree.find_leaves t x >|= Option.some + + let check_hash k v = + let k' = H.hash (pre_hash_value v) in + if equal_key k k' then Lwt.return_unit + else + Fmt.kstr Lwt.fail_invalid_arg "corrupted value: got %a, expecting %a" + pp_key k' pp_key k + + let find t key = + find_leaves t key >>= function + | None -> Lwt.return_none + | Some bufs -> ( + let buf = String.concat "" bufs in + match value_of_bin_string buf with + | Ok va -> check_hash key va >|= fun () -> Some va + | Error _ -> Lwt.return_none) + + let list_range ~init ~stop ~step = + let rec aux acc n = + if n >= stop then List.rev acc else aux (n :: acc) (n + step) + in + aux [] init + + let unsafe_add_buffer t key buf = + let len = String.length buf in + if len <= t.max_data then + AO.add t.db key (data t buf) >|= fun () -> + [%log.debug "add -> %a (no split)" pp_key key] + else + let offs = list_range ~init:0 ~stop:len ~step:t.max_data in + let aux off = + let len = min t.max_data (String.length buf - off) in + let payload = String.sub buf off len in + CA.add t.db (data t payload) + in + let+ k = Lwt_list.map_s aux offs >>= Tree.add ~key t in + [%log.debug "add -> %a (split)" pp_key k] + + let add t v = + let buf = value_to_bin_string v in + let key = H.hash (pre_hash_value v) in + let+ () = unsafe_add_buffer t key buf in + key + + let unsafe_add t key v = + let buf = value_to_bin_string v in + unsafe_add_buffer t key buf + + let mem t key = CA.mem t.db key +end diff --git a/vendors/irmin/src/irmin-chunk/irmin_chunk.mli b/vendors/irmin/src/irmin-chunk/irmin_chunk.mli new file mode 100644 index 0000000000000000000000000000000000000000..338a09427f5b8cdce806c718d639e0d133fb9756 --- /dev/null +++ b/vendors/irmin/src/irmin-chunk/irmin_chunk.mli @@ -0,0 +1,91 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2015 Mounir Nasr Allah + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** This package provides an Irmin backend to cut raw contents into blocks of + the same size, while preserving the keys used in the store. It can be used + to optimize space usage when dealing with large files or as an intermediate + layer for a raw block device backend. *) + +(** {1 Managing Chunks} + + This module exposes functors to store raw contents into append-only stores + as chunks of same size. It exposes the {{!AO} AO} functor which split the + raw contents into [Data] blocks, addressed by [Node] blocks. That's the + usual rope-like representation of strings, but chunk trees are always built + as perfectly well-balanced and blocks are addressed by their hash (or by the + stable keys returned by the underlying store). + + A chunk has the following structure: + + {v + -------------------------- -------------------------- + | uint8_t type | | uint8_t type | + --------------------------- --------------------------- + | uint16_t | | uint64_t | + --------------------------- --------------------------- + | key children[length] | | byte data[length] | + --------------------------- --------------------------- + v} + + [type] is either [Data] (0) or [Index] (1). If the chunk contains data, + [length] is the payload length. Otherwise it is the number of children that + the node has. + + It also exposes {{!AO_stable} AO_stable} which -- as {{!AO} AO} does -- + stores raw contents into chunks of same size. But it also preserves the nice + property that values are addressed by their hash, instead of by the hash of + the root chunk node as is the case for {{!AO} AO}. *) + +module Conf : sig + open Irmin.Backend.Conf + + val spec : Spec.t + + module Key : sig + val chunk_size : int key + (** [chunk_size] is the configuration key to configure chunk size. By + default, it is set to 4666, so that payload and metadata can be stored + in a 4K block. *) + + val min_size : int key + val chunking : [ `Best_fit | `Max ] key + end +end + +val config : + ?size:int -> + ?min_size:int -> + ?chunking:[ `Max | `Best_fit ] -> + Irmin.config -> + Irmin.config +(** [config ?config ?size ?min_size ()] is the configuration value extending the + optional [config] with bindings associating {{!Conf.Key.chunk_size} + chunk_size} to [size]. + + If [chunking] is [Best_fit] (the default), the size of new chunks will be of + maximum [max_size] but could be smaller if they don't need to be chunked. If + [chunking] is [Max], all the new chunks will be of size [max_size]. + + Fail with [Invalid_argument] if [size] is smaller than [min_size]. + [min_size] is, by default, set to 4000 (to avoid hash collisions on smaller + sizes) but can be tweaked for testing purposes. {i Notes:} the smaller + [size] is, the bigger the risk of hash collisions, so use reasonable values. *) + +(** [Content_addressable(X)] is a content-addressable store which store values + cut into chunks into the underlying store [X]. *) +module Content_addressable (S : Irmin.Append_only.Maker) : + Irmin.Content_addressable.Maker diff --git a/vendors/irmin/src/irmin-cli/bin/dune b/vendors/irmin/src/irmin-cli/bin/dune new file mode 100644 index 0000000000000000000000000000000000000000..f4073837cceb3a99b24a75973551b8327fc77d01 --- /dev/null +++ b/vendors/irmin/src/irmin-cli/bin/dune @@ -0,0 +1,5 @@ +(executable + (name main) + (public_name irmin) + (package irmin-cli) + (libraries irmin-cli)) diff --git a/vendors/irmin/src/irmin-cli/bin/main.ml b/vendors/irmin/src/irmin-cli/bin/main.ml new file mode 100644 index 0000000000000000000000000000000000000000..2ba8b5d33369dbe96bbe3c5ec79f089ace4946d5 --- /dev/null +++ b/vendors/irmin/src/irmin-cli/bin/main.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let () = Irmin_cli.(run ~default commands) diff --git a/vendors/irmin/src/irmin-cli/cli.ml b/vendors/irmin/src/irmin-cli/cli.ml new file mode 100644 index 0000000000000000000000000000000000000000..8e36a2a6bf52d01fcc140903f324216c18808438 --- /dev/null +++ b/vendors/irmin/src/irmin-cli/cli.ml @@ -0,0 +1,1058 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Cmdliner +open Resolver +module Http = Irmin_http_unix +module Graphql = Irmin_graphql_unix + +let deprecated_info = (Term.info [@alert "-deprecated"]) +let deprecated_man_format = (Term.man_format [@alert "-deprecated"]) +let deprecated_eval_choice = (Term.eval_choice [@alert "-deprecated"]) +let () = Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook + +let info (type a) (module S : Irmin.Generic_key.S with type Schema.Info.t = a) + ?(author = "irmin") fmt = + let module Info = Info.Make (S.Info) in + Info.v ~author fmt + +(* Help sections common to all commands *) +let help_sections = + [ + `S global_option_section; + `P "These options can be passed to any command"; + `S "AUTHORS"; + `P "Thomas Gazagnaire "; + `S "BUGS"; + `P "Check bug reports at https://github.com/mirage/irmin/issues."; + ] + +let setup_log style_renderer level = + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (Logs_fmt.reporter ()); + () + +let setup_log = + Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) + +let term_info title ~doc ~man = + let man = man @ help_sections in + deprecated_info ~sdocs:global_option_section ~docs:global_option_section ~doc + ~man title + +type command = (unit Term.t * Term.info[@alert "-deprecated"]) + +type sub = { + name : string; + doc : string; + man : Manpage.block list; + term : unit Term.t; +} + +let create_command c = + let man = [ `S "DESCRIPTION"; `P c.doc ] @ c.man in + (c.term, term_info c.name ~doc:c.doc ~man) + +(* Converters *) + +let pr_str = Format.pp_print_string + +let path = + let path_conv = + let parse str = `Ok str in + let print ppf path = pr_str ppf path in + (parse, print) + in + let doc = Arg.info ~docv:"PATH" ~doc:"Key to lookup or modify." [] in + Arg.(required & pos 0 (some path_conv) None & doc) + +type path_or_empty = Empty | Path of string + +let path_or_empty = + let path_conv = + let parse str = `Ok (Path str) in + let print = Fmt.of_to_string (function Path str -> str | Empty -> "/") in + (parse, print) + in + let doc = + Arg.info [] ~docv:"PATH" + ~doc: + "Path to lookup or modify. Defaults to the empty path (which queries \ + the root tree of a store)." + in + Arg.(value & pos 0 path_conv Empty & doc) + +let depth = + let doc = + Arg.info ~docv:"DEPTH" ~doc:"Limit the history depth." [ "d"; "depth" ] + in + Arg.(value & opt (some int) None & doc) + +let print_exc exc = + (match exc with + | Failure f -> Fmt.epr "ERROR: %s\n%!" f + | e -> Fmt.epr "ERROR: %a\n%!" Fmt.exn e); + exit 1 + +let run t = Lwt_main.run (Lwt.catch (fun () -> t) print_exc) +let mk (fn : 'a) : 'a Term.t = Term.(const (fun () -> fn) $ setup_log) + +(* INIT *) +let init = + { + name = "init"; + doc = "Initialize a store."; + man = []; + term = + (let init (S (_, _store, _)) = run Lwt.return_unit in + Term.(mk init $ store ())); + } + +(* HTTP *) +let http = + { + name = "http"; + doc = "Run http server"; + man = []; + term = + (let uri = + let doc = + Arg.info ~docv:"URI" [ "a"; "address" ] + ~doc: + "Start the Irmin server on the given socket address. Examples \ + include http://localhost:8080 and launchd://Listener." + in + Arg.(value & opt string "http://localhost:8080" & doc) + in + let init (S (impl, store, _)) uri = + let (module S) = + match Store.Impl.hash_keyed impl with + | Some x -> x + | None -> + Fmt.failwith + "Unsupported backend: can't start an HTTP server with a store \ + that is not keyed by hashes" + in + run + (let* t = store in + let module HTTP = Http.Server (S) in + let uri = Uri.of_string uri in + let spec = HTTP.v (S.repo t) in + match Uri.scheme uri with + | Some "launchd" -> + let uri, name = + match Uri.host uri with + | None -> (Uri.with_host uri (Some "Listener"), "Listener") + | Some name -> (uri, name) + in + [%logs.info "daemon: %s" (Uri.to_string uri)]; + Cohttp_lwt_unix.Server.create ~timeout:3600 + ~mode:(`Launchd name) spec + | _ -> + let uri = + match Uri.host uri with + | None -> Uri.with_host uri (Some "localhost") + | Some _ -> uri + in + let port, uri = + match Uri.port uri with + | None -> (8080, Uri.with_port uri (Some 8080)) + | Some p -> (p, uri) + in + [%logs.info "daemon: %s" (Uri.to_string uri)]; + Printf.printf "Server starting on port %d.\n%!" port; + Cohttp_lwt_unix.Server.create ~timeout:3600 + ~mode:(`TCP (`Port port)) + spec) + in + Term.(mk init $ store () $ uri)); + } + +let print fmt = Fmt.kstr print_endline fmt + +let get name f x = + match Irmin.Type.of_string f x with + | Ok x -> x + | Error (`Msg e) -> Fmt.kstr invalid_arg "invalid %s: %s" name e + +let key f x = get "key" f x +let value f x = get "value" f x +let branch f x = get "branch" f x +let commit f x = get "commit" f x + +(* GET *) +let get = + { + name = "get"; + doc = "Read the value associated with a key."; + man = []; + term = + (let get (S (impl, store, _)) path = + let (module S) = Store.Impl.generic_keyed impl in + run + (let* t = store in + S.find t (key S.Path.t path) >>= function + | None -> + print ""; + exit 1 + | Some v -> + print "%a" (Irmin.Type.pp S.Contents.t) v; + Lwt.return_unit) + in + Term.(mk get $ store () $ path)); + } + +(* LIST *) +let list = + { + name = "list"; + doc = "List subdirectories."; + man = []; + term = + (let list (S (impl, store, _)) path_or_empty = + let (module S) = Store.Impl.generic_keyed impl in + let path = + match path_or_empty with + | Empty -> S.Path.empty + | Path str -> key S.Path.t str + in + run + (let* t = store in + let* paths = S.list t path in + let pp_step = Irmin.Type.pp S.Path.step_t in + let pp ppf (s, k) = + match S.Tree.destruct k with + | `Contents _ -> Fmt.pf ppf "FILE %a" pp_step s + | `Node _ -> Fmt.pf ppf "DIR %a" pp_step s + in + List.iter (print "%a" pp) paths; + Lwt.return_unit) + in + Term.(mk list $ store () $ path_or_empty)); + } + +(* TREE *) +let tree = + { + name = "tree"; + doc = "List the store contents."; + man = []; + term = + (let tree (S (impl, store, _)) = + let (module S) = Store.Impl.generic_keyed impl in + run + (let* t = store in + let all = ref [] in + let todo = ref [ S.Path.empty ] in + let rec walk () = + match !todo with + | [] -> Lwt.return_unit + | k :: rest -> + todo := rest; + let* childs = S.list t k in + Lwt_list.iter_p + (fun (s, c) -> + let k = S.Path.rcons k s in + match S.Tree.destruct c with + | `Node _ -> + todo := k :: !todo; + Lwt.return_unit + | `Contents _ -> + let+ v = S.get t k in + all := (k, v) :: !all) + childs + >>= walk + in + walk () >>= fun () -> + let all = !all in + let all = + List.map + (fun (k, v) -> + ( Irmin.Type.to_string S.Path.t k, + Irmin.Type.to_string S.Contents.t v )) + all + in + let max_length l = + List.fold_left (fun len s -> max len (String.length s)) 0 l + in + let k_max = max_length (List.map fst all) in + let v_max = max_length (List.map snd all) in + let pad = 79 + k_max + v_max in + List.iter + (fun (k, v) -> + let dots = + String.make (pad - String.length k - String.length v) '.' + in + print "%s%s%s" k dots v) + all; + Lwt.return_unit) + in + Term.(mk tree $ store ())); + } + +let author = + let doc = Arg.info ~docv:"NAME" ~doc:"Commit author name." [ "author" ] in + Arg.(value & opt (some string) None & doc) + +let message = + let doc = Arg.info ~docv:"MESSAGE" ~doc:"Commit message." [ "message" ] in + Arg.(value & opt (some string) None & doc) + +(* SET *) +let set = + { + name = "set"; + doc = "Update the value associated with a key."; + man = []; + term = + (let v = + let doc = Arg.info ~docv:"VALUE" ~doc:"Value to add." [] in + Arg.(required & pos 1 (some string) None & doc) + in + let set (S (impl, store, _)) author message path v = + let (module S) = Store.Impl.generic_keyed impl in + run + (let message = match message with Some s -> s | None -> "set" in + let* t = store in + let path = key S.Path.t path in + let value = value S.Contents.t v in + S.set_exn t ~info:(info (module S) ?author "%s" message) path value) + in + Term.(mk set $ store () $ author $ message $ path $ v)); + } + +(* REMOVE *) +let remove = + { + name = "remove"; + doc = "Delete a key."; + man = []; + term = + (let remove (S (impl, store, _)) author message path = + let (module S) = Store.Impl.generic_keyed impl in + run + (let message = + match message with Some s -> s | None -> "remove " ^ path + in + let* t = store in + S.remove_exn t + ~info:(info (module S) ?author "%s" message) + (key S.Path.t path)) + in + Term.(mk remove $ store () $ author $ message $ path)); + } + +let apply e f = + match (e, f) with + | R (h, e), Some f -> f ?ctx:None ?headers:h e + | R _, None -> Fmt.failwith "invalid remote for that kind of store" + | r, _ -> Lwt.return r + +(* CLONE *) +let clone = + { + name = "clone"; + doc = "Copy a remote respository to a local store"; + man = []; + term = + (let clone (S (impl, store, f), remote) depth = + let (module S) = Store.Impl.generic_keyed impl in + let module Sync = Irmin.Sync.Make (S) in + run + (let* t = store in + let* r = remote in + let* x = apply r f in + Sync.fetch t ?depth x >>= function + | Ok (`Head d) -> S.Head.set t d + | Ok `Empty -> Lwt.return_unit + | Error (`Msg e) -> failwith e) + in + Term.(mk clone $ remote () $ depth)); + } + +(* FETCH *) +let fetch = + { + name = "fetch"; + doc = "Download objects and refs from another repository."; + man = []; + term = + (let fetch (S (impl, store, f), remote) = + let (module S) = Store.Impl.generic_keyed impl in + let module Sync = Irmin.Sync.Make (S) in + run + (let* t = store in + let* r = remote in + let branch = branch S.Branch.t "import" in + let* t = S.of_branch (S.repo t) branch in + let* x = apply r f in + let* _ = Sync.pull_exn t x `Set in + Lwt.return_unit) + in + Term.(mk fetch $ remote ())); + } + +(* MERGE *) +let merge = + { + name = "merge"; + doc = "Merge branches."; + man = []; + term = + (let merge (S (impl, store, _)) author message branch = + let (module S) = Store.Impl.generic_keyed impl in + run + (let message = match message with Some s -> s | None -> "merge" in + let branch = + match Irmin.Type.of_string S.Branch.t branch with + | Ok b -> b + | Error (`Msg msg) -> failwith msg + in + let* t = store in + S.merge_with_branch t branch + ~info:(info (module S) ?author "%s" message) + >|= function + | Ok () -> () + | Error conflict -> + let fmt = Irmin.Type.pp_json Irmin.Merge.conflict_t in + Fmt.epr "CONFLICT: %a\n%!" fmt conflict) + in + let branch_name = + let doc = Arg.info ~docv:"BRANCH" ~doc:"Branch to merge from." [] in + Arg.(required & pos 0 (some string) None & doc) + in + Term.(mk merge $ store () $ author $ message $ branch_name)); + } + +(* PULL *) +let pull = + { + name = "pull"; + doc = "Fetch and merge with another repository."; + man = []; + term = + (let pull (S (impl, store, f), remote) author message = + let (module S) = Store.Impl.generic_keyed impl in + let message = match message with Some s -> s | None -> "pull" in + let module Sync = Irmin.Sync.Make (S) in + run + (let* t = store in + let* r = remote in + let* x = apply r f in + let* _ = + Sync.pull_exn t x (`Merge (info (module S) ?author "%s" message)) + in + Lwt.return_unit) + in + Term.(mk pull $ remote () $ author $ message)); + } + +(* PUSH *) +let push = + { + name = "push"; + doc = "Update remote references along with associated objects."; + man = []; + term = + (let push (S (impl, store, f), remote) = + let (module S) = Store.Impl.generic_keyed impl in + let module Sync = Irmin.Sync.Make (S) in + run + (let* t = store in + let* r = remote in + let* x = apply r f in + let* _ = Sync.push_exn t x in + Lwt.return_unit) + in + Term.(mk push $ remote ())); + } + +(* SNAPSHOT *) +let snapshot = + { + name = "snapshot"; + doc = "Return a snapshot for the current state of the database."; + man = []; + term = + (let snapshot (S (impl, store, _)) = + let (module S) = Store.Impl.generic_keyed impl in + run + (let* t = store in + let* k = S.Head.get t in + print "%a" S.Commit.pp_hash k; + Lwt.return_unit) + in + Term.(mk snapshot $ store ())); + } + +(* REVERT *) +let revert = + { + name = "revert"; + doc = "Revert the contents of the store to a previous state."; + man = []; + term = + (let snapshot = + let doc = + Arg.info ~docv:"SNAPSHOT" ~doc:"The snapshot to revert to." [] + in + Arg.(required & pos 0 (some string) None & doc) + in + let revert (S (impl, store, _)) snapshot = + let (module S) = Store.Impl.generic_keyed impl in + run + (let* t = store in + let hash = commit S.Hash.t snapshot in + let* s = S.Commit.of_hash (S.repo t) hash in + match s with + | Some s -> S.Head.set t s + | None -> failwith "invalid commit") + in + Term.(mk revert $ store () $ snapshot)); + } + +(* WATCH *) + +let run_command (type a b c) + (module S : Irmin.Generic_key.S + with type Schema.Path.t = a + and type Schema.Contents.t = b + and type Schema.Metadata.t = c) diff command proc = + let simple_output (k, v) = + let x = + match v with `Updated _ -> "*" | `Added _ -> "+" | `Removed _ -> "-" + in + print "%s %a" x (Irmin.Type.pp S.Path.t) k; + Lwt.return_unit + in + (* Check if there was a command passed, if not print a simple message to stdout, if there is + a command pass the whole diff *) + match command with + | h :: t -> + let ty = [%typ: (S.path * (S.contents * S.metadata) Irmin.Diff.t) list] in + let s = Fmt.str "%a" (Irmin.Type.pp_json ty) diff in + let make_proc () = + (* Start new process *) + let p = Lwt_process.open_process_out (h, Array.of_list (h :: t)) in + proc := Some p; + p + in + let proc = + (* Check if process is already running, if not run it *) + match !proc with + | None -> make_proc () + | Some p -> ( + (* Determine if the subprocess completed succesfully or exited with an error, + if it was successful then we can restart it, otherwise report the exit code + the user *) + let status = p#state in + match status with + | Lwt_process.Running -> p + | Exited (Unix.WEXITED 0) -> make_proc () + | Exited (Unix.WEXITED code) -> + Printf.printf "Subprocess exited with code %d\n" code; + exit code + | Exited (Unix.WSIGNALED code) | Exited (Unix.WSTOPPED code) -> + Printf.printf "Subprocess stopped with code %d\n" code; + exit code) + in + (* Write the diff to the subprocess *) + let* () = Lwt_io.write_line proc#stdin s in + Lwt_io.flush proc#stdin + | [] -> Lwt_list.iter_s simple_output diff + +let handle_diff (type a b) + (module S : Irmin.Generic_key.S + with type Schema.Path.t = a + and type commit = b) (path : a) command proc d = + let view (c, _) = + let* t = S.of_commit c in + S.find_tree t path >|= function None -> S.Tree.empty () | Some v -> v + in + let* x, y = + match d with + | `Updated (x, y) -> + let* x = view x in + let+ y = view y in + (x, y) + | `Added x -> + let+ x = view x in + (S.Tree.empty (), x) + | `Removed x -> + let+ x = view x in + (x, S.Tree.empty ()) + in + let* (diff : (S.path * (S.contents * S.metadata) Irmin.Diff.t) list) = + S.Tree.diff x y + in + run_command + (module S : Irmin.Generic_key.S + with type Schema.Path.t = S.path + and type Schema.Contents.t = S.contents + and type Schema.Metadata.t = S.metadata) + diff command proc + +let watch = + { + name = "watch"; + doc = "Get notifications when values change."; + man = []; + term = + (let watch (S (impl, store, _)) path command = + let (module S) = Store.Impl.generic_keyed impl in + let path = key S.Path.t path in + let proc = ref None in + let () = + at_exit (fun () -> + match !proc with None -> () | Some p -> p#terminate) + in + run + (let* t = store in + let* _ = + S.watch_key t path + (handle_diff + (module S : Irmin.Generic_key.S + with type Schema.Path.t = S.path + and type commit = S.commit) + path command proc) + in + let t, _ = Lwt.task () in + t) + in + let command = + let doc = Arg.info ~docv:"COMMAND" ~doc:"Command to execute" [] in + Arg.(value & pos_right 0 string [] & doc) + in + Term.(mk watch $ store () $ path $ command)); + } + +(* DOT *) +let dot = + { + name = "dot"; + doc = "Dump the contents of the store as a Graphviz file."; + man = []; + term = + (let basename = + let doc = + Arg.info ~docv:"BASENAME" + ~doc:"Basename for the .dot and .png files." [] + in + Arg.(required & pos 0 (some string) None & doc) + in + let no_dot_call = + let doc = + Arg.info + ~doc:"Do not call the `dot' utility on the generated `.dot` file." + [ "no-dot-call" ] + in + Arg.(value & flag & doc) + in + let full = + let doc = + Arg.info + ~doc: + "Show the full graph of objects, including the filesystem nodes \ + and the content blobs." + [ "full" ] + in + Arg.(value & flag & doc) + in + let dot (S (impl, store, _)) basename depth no_dot_call full = + let (module S) = Store.Impl.generic_keyed impl in + let module Dot = Irmin.Dot (S) in + let date d = + let tm = Unix.localtime (Int64.to_float d) in + Printf.sprintf "%2d:%2d:%2d" tm.Unix.tm_hour tm.Unix.tm_min + tm.Unix.tm_sec + in + run + (let* t = store in + let call_dot = not no_dot_call in + let buf = Buffer.create 1024 in + Dot.output_buffer ~html:false t ?depth ~full ~date buf >>= fun () -> + let oc = open_out_bin (basename ^ ".dot") in + let* () = + Lwt.finalize + (fun () -> + output_string oc (Buffer.contents buf); + Lwt.return_unit) + (fun () -> + close_out oc; + Lwt.return_unit) + in + if call_dot then ( + let i = Sys.command "/bin/sh -c 'command -v dot'" in + if i <> 0 then + [%logs.err + "Cannot find the `dot' utility. Please install it on your \ + system and be sure it is available in your $PATH."]; + let i = + Sys.command + (Printf.sprintf "dot -Tpng %s.dot -o%s.png" basename basename) + in + if i <> 0 then [%logs.err "The %s.dot is corrupted" basename]); + Lwt.return_unit) + in + Term.(mk dot $ store () $ basename $ depth $ no_dot_call $ full)); + } + +let config_man = + let version_string = Printf.sprintf "Irmin %s" Irmin.version in + ( ("irmin.yml", 5, "", version_string, "Irmin Manual"), + [ + `S Manpage.s_name; + `P "irmin.yml"; + `S Manpage.s_synopsis; + `P + "Configure certain command-line options to cut down on mistakes and \ + save on typing"; + `S Manpage.s_description; + `P + "An $(b,irmin.yml) file lets the user specify repetitve command-line \ + options in a YAML file. The $(b,irmin.yml) is read by default if it \ + is found in the current working directory or defined globally as \ + \\$HOME/.config/irmin/config.yml. The configuration file path can \ + also be set using the $(b,--config) command-line flag or by setting \ + \\$XDG_CONFIG_HOME. \n\ + \ The following keys are allowed: $(b,contents), $(b,store), \ + $(b,branch), $(b,root), $(b,bare) or $(b,head). These correspond to \ + the irmin options of the same names. Additionally, specific\n\ + \ backends may have other options available, these can be \ + lised using the $(b,options)\n\ + \ command and applied using the $(b,--opt) flag."; + `S Manpage.s_examples; + `P + "Here is an example $(b,irmin.yml) for accessing a local http irmin \ + store. This $(b,irmin.yml) prevents the user from having to specify \ + the $(b,store) and $(b,root) options for every command."; + `Pre " \\$ cat irmin.yml\n store: pack\n root: /path/to/my/store"; + ] + @ help_sections ) + +(* HELP *) +let help = + { + name = "help"; + doc = "Display help about Irmin and Irmin commands."; + man = + [ `P "Use `$(mname) help topics' to get the full list of help topics." ]; + term = + (let topic = + let doc = Arg.info [] ~docv:"TOPIC" ~doc:"The topic to get help on." in + Arg.(value & pos 0 (some string) None & doc) + in + let help man_format cmds topic = + match topic with + | None -> `Help (`Pager, None) + | Some topic -> ( + let topics = "irmin.yml" :: cmds in + let conv, _ = + Arg.enum (List.rev_map (fun s -> (s, s)) ("topics" :: topics)) + in + match conv topic with + | `Error e -> `Error (false, e) + | `Ok t when t = "topics" -> + List.iter print_endline topics; + `Ok () + | `Ok t when t = "irmin.yml" -> + `Ok + (Cmdliner.Manpage.print man_format Format.std_formatter + config_man) + | `Ok t -> `Help (man_format, Some t)) + in + Term.(ret (mk help $ deprecated_man_format $ Term.choice_names $ topic))); + } + +(* GRAPHQL *) +let graphql = + { + name = "graphql"; + doc = "Run a graphql server."; + man = []; + term = + (let port = + let doc = Arg.info ~doc:"Port for graphql server." [ "p"; "port" ] in + Arg.(value & opt int 8080 & doc) + in + let addr = + let doc = + Arg.info ~doc:"Address for graphql server." [ "a"; "address" ] + in + Arg.(value & opt string "localhost" & doc) + in + let graphql (S (impl, store, remote_fn)) port addr = + let (module S) = Store.Impl.generic_keyed impl in + run + (let module Server = + Graphql.Server.Make + (S) + (struct + let remote = remote_fn + end) + in + let* t = store in + let server = Server.v (S.repo t) in + let* ctx = Conduit_lwt_unix.init ~src:addr () in + let ctx = Cohttp_lwt_unix.Net.init ~ctx () in + let on_exn exn = + [%logs.debug "on_exn: %s" (Printexc.to_string exn)] + in + Cohttp_lwt_unix.Server.create ~on_exn ~ctx + ~mode:(`TCP (`Port port)) + server) + in + Term.(mk graphql $ store () $ port $ addr)); + } + +let options = + { + name = "options"; + doc = "Get information about backend specific configuration options."; + man = []; + term = + (let options (store, hash, contents) = + let module Conf = Irmin.Backend.Conf in + let store, _ = Resolver.load_config ?store ?hash ?contents () in + let spec = Store.spec store in + Seq.iter + (fun (Conf.K k) -> + let name = Conf.name k in + if name = "root" || name = "uri" then () + else + let ty = Conf.ty k in + let doc = Conf.doc k |> Option.value ~default:"" in + let ty = + Fmt.str "%a" Irmin.Type.pp_ty ty + |> Astring.String.filter (fun c -> c <> '\n') + in + Fmt.pr "%s: %s\n\t%s\n" name ty doc) + (Conf.Spec.keys spec) + in + Term.(mk options $ Store.term ())); + } + +let branches = + { + name = "branches"; + doc = "List branches"; + man = []; + term = + (let branches (S (impl, store, _)) = + let (module S) = Store.Impl.generic_keyed impl in + run + (let* t = store in + let+ branches = S.Branch.list (S.repo t) in + List.iter (Fmt.pr "%a\n" (Irmin.Type.pp S.branch_t)) branches) + in + Term.(mk branches $ store ())); + } + +let weekday Unix.{ tm_wday; _ } = + match tm_wday with + | 0 -> "Sun" + | 1 -> "Mon" + | 2 -> "Tue" + | 3 -> "Wed" + | 4 -> "Thu" + | 5 -> "Fri" + | 6 -> "Sat" + | _ -> assert false + +let month Unix.{ tm_mon; _ } = + match tm_mon with + | 0 -> "Jan" + | 1 -> "Feb" + | 2 -> "Mar" + | 3 -> "Apr" + | 4 -> "May" + | 5 -> "Jun" + | 6 -> "Jul" + | 7 -> "Aug" + | 8 -> "Sep" + | 9 -> "Oct" + | 10 -> "Nov" + | 11 -> "Dec" + | _ -> assert false + +let log = + { + name = "log"; + doc = "List commits"; + man = []; + term = + (let plain = + let doc = Arg.info ~doc:"Show plain text without pager" [ "plain" ] in + Arg.(value & flag & doc) + in + let pager = + let doc = Arg.info ~doc:"Specify pager program to use" [ "pager" ] in + Arg.(value & opt string "pager" & doc) + in + let num = + let doc = + Arg.info ~doc:"Number of entries to show" [ "n"; "max-count" ] + in + Arg.(value & opt (some int) None & doc) + in + let skip = + let doc = Arg.info ~doc:"Number of entries to skip" [ "skip" ] in + Arg.(value & opt (some int) None & doc) + in + let reverse = + let doc = Arg.info ~doc:"Print in reverse order" [ "reverse" ] in + Arg.(value & flag & doc) + in + let exception Return in + let commits (S (impl, store, _)) plain pager num skip reverse = + let (module S) = Store.Impl.generic_keyed impl in + run + (let* t = store in + let fmt f date = + Fmt.pf f "%s %s %02d %02d:%02d:%02d %04d" (weekday date) + (month date) date.tm_mday date.tm_hour date.tm_min date.tm_sec + (date.tm_year + 1900) + in + let repo = S.repo t in + let skip = ref (Option.value ~default:0 skip) in + let num = Option.value ~default:0 num in + let num_count = ref 0 in + let commit formatter key = + if num > 0 && !num_count >= num then raise Return + else if !skip > 0 then + let () = decr skip in + Lwt.return_unit + else + let+ commit = S.Commit.of_key repo key >|= Option.get in + let hash = S.Backend.Commit.Key.to_hash key in + let info = S.Commit.info commit in + let date = S.Info.date info in + let author = S.Info.author info in + let message = S.Info.message info in + let date = Unix.localtime (Int64.to_float date) in + let () = + Fmt.pf formatter "commit %a\nAuthor: %s\nDate: %a\n\n%s\n\n%!" + (Irmin.Type.pp S.hash_t) hash author fmt date message + in + incr num_count + in + let* max = S.Head.get t >|= fun x -> [ `Commit (S.Commit.key x) ] in + let iter ~commit ~max repo = + Lwt.catch + (fun () -> + if reverse then S.Repo.iter ~commit ~min:[] ~max repo + else S.Repo.breadth_first_traversal ~commit ~max repo) + (function Return -> Lwt.return_unit | exn -> raise exn) + in + if plain then + let commit = commit Format.std_formatter in + iter ~commit ~max repo + else + Lwt.catch + (fun () -> + let out = Unix.open_process_out pager in + let commit = commit (Format.formatter_of_out_channel out) in + let+ () = iter ~commit ~max repo in + let _ = Unix.close_process_out out in + ()) + (function + | Sys_error s when String.equal s "Broken pipe" -> + Lwt.return_unit + | exn -> raise exn)) + in + Term.(mk commits $ store () $ plain $ pager $ num $ skip $ reverse)); + } + +let default = + let doc = "Irmin, the database that never forgets." in + let man = + [ + `S "DESCRIPTION"; + `P + "Irmin is a distributed database used primarily for application data. \ + It is designed to work with a large variety of backends and has \ + built-in snapshotting, reverting and branching mechanisms."; + `P + "Use either $(mname) --help or $(mname) help for \ + more information on a specific command."; + ] + in + let usage () = + Fmt.pr + "usage: irmin [--version]\n\ + \ [--help]\n\ + \ []\n\n\ + The most commonly used subcommands are:\n\ + \ init %s\n\ + \ get %s\n\ + \ set %s\n\ + \ remove %s\n\ + \ list %s\n\ + \ tree %s\n\ + \ clone %s\n\ + \ fetch %s\n\ + \ merge %s\n\ + \ pull %s\n\ + \ push %s\n\ + \ snapshot %s\n\ + \ revert %s\n\ + \ watch %s\n\ + \ dot %s\n\ + \ graphql %s\n\ + \ http %s\n\ + \ options %s\n\ + \ branches %s\n\ + \ log %s\n\n\ + See `irmin help ` for more information on a specific command.\n\ + %!" + init.doc get.doc set.doc remove.doc list.doc tree.doc clone.doc fetch.doc + merge.doc pull.doc push.doc snapshot.doc revert.doc watch.doc dot.doc + graphql.doc http.doc options.doc branches.doc log.doc + in + ( Term.(mk usage $ const ()), + deprecated_info "irmin" ~version:Irmin.version ~sdocs:global_option_section + ~doc ~man ) + +let commands = + List.map create_command + [ + help; + init; + http; + get; + set; + remove; + list; + tree; + clone; + fetch; + merge; + pull; + push; + snapshot; + revert; + watch; + dot; + graphql; + options; + branches; + log; + ] + +let run ~default:x y = + match deprecated_eval_choice x y with `Error _ -> exit 1 | _ -> () diff --git a/vendors/irmin/src/irmin-cli/cli.mli b/vendors/irmin/src/irmin-cli/cli.mli new file mode 100644 index 0000000000000000000000000000000000000000..6141f56afa6be5385d1b47cdd90389fad4c9d733 --- /dev/null +++ b/vendors/irmin/src/irmin-cli/cli.mli @@ -0,0 +1,42 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** CLI commands. *) + +type command = (unit Cmdliner.Term.t * Cmdliner.Term.info[@alert "-deprecated"]) +(** [Cmdliner] commands. *) + +val default : command +(** The default command: show a summary of the commands. *) + +val commands : command list +(** List of available sub-commands. *) + +val run : default:command -> command list -> unit +(** Create a command-line tool with the given subcommands. *) + +(** {2 Command-builder helper} *) + +type sub = { + name : string; + doc : string; + man : Cmdliner.Manpage.block list; + term : unit Cmdliner.Term.t; +} +(** Subcommand. *) + +val create_command : sub -> command +(** Build a subcommand. *) diff --git a/vendors/irmin/src/irmin-cli/dune b/vendors/irmin/src/irmin-cli/dune new file mode 100644 index 0000000000000000000000000000000000000000..fef4f2b5cf9c99f2c51093ccb2efb79ab3ee0242 --- /dev/null +++ b/vendors/irmin/src/irmin-cli/dune @@ -0,0 +1,23 @@ +(library + (name irmin_cli) + (public_name irmin-cli) + (libraries + astring + dynlink + irmin + irmin-tezos + irmin-pack.unix + irmin-git.unix + irmin-fs.unix + irmin-graphql.unix + irmin-http.unix + irmin-watcher + cmdliner + git-unix + cohttp-lwt-unix + unix + yaml) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-cli/import.ml b/vendors/irmin/src/irmin-cli/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..fff6d09bdbae3abdf0aa281eafe8bcd83d3b956b --- /dev/null +++ b/vendors/irmin/src/irmin-cli/import.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/src/irmin-cli/info.ml b/vendors/irmin/src/irmin-cli/info.ml new file mode 100644 index 0000000000000000000000000000000000000000..e8a35aa652dcef031e1b0a7883c58f4f2c56ef59 --- /dev/null +++ b/vendors/irmin/src/irmin-cli/info.ml @@ -0,0 +1,34 @@ +(* + * Copyright (c) 2013-2021 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Irmin.Info.S) = struct + include I + + let v ?author fmt = + Fmt.kstr + (fun message () -> + let date = Int64.of_float (Unix.gettimeofday ()) in + let author = + match author with + | Some a -> a + | None -> + (* XXX: get "git config user.name" *) + Printf.sprintf "Irmin %s.[%d]" (Unix.gethostname ()) + (Unix.getpid ()) + in + v ~author ~message date) + fmt +end diff --git a/vendors/irmin/src/irmin-cli/info.mli b/vendors/irmin/src/irmin-cli/info.mli new file mode 100644 index 0000000000000000000000000000000000000000..515845dc751178a5a285f97186a440bccf275c27 --- /dev/null +++ b/vendors/irmin/src/irmin-cli/info.mli @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2013-2021 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Irmin.Info.S) : sig + include Irmin.Info.S with type t = I.t + + val v : ?author:string -> ('b, Format.formatter, unit, f) format4 -> 'b +end diff --git a/vendors/irmin/src/irmin-cli/irmin_cli.ml b/vendors/irmin/src/irmin-cli/irmin_cli.ml new file mode 100644 index 0000000000000000000000000000000000000000..929dcffa71c5a5c5aba730d6e9603b83e15da699 --- /dev/null +++ b/vendors/irmin/src/irmin-cli/irmin_cli.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Cli +module Resolver = Resolver diff --git a/vendors/irmin/src/irmin-cli/irmin_cli.mli b/vendors/irmin/src/irmin-cli/irmin_cli.mli new file mode 100644 index 0000000000000000000000000000000000000000..d2ee8e93e26e4a50d610d42072617eece9017ec6 --- /dev/null +++ b/vendors/irmin/src/irmin-cli/irmin_cli.mli @@ -0,0 +1,7 @@ +include module type of Cli +(** @inline *) + +module Resolver : sig + include module type of Resolver + (** @inline *) +end diff --git a/vendors/irmin/src/irmin-cli/resolver.ml b/vendors/irmin/src/irmin-cli/resolver.ml new file mode 100644 index 0000000000000000000000000000000000000000..e0c2a250a7812f5b5636a08391016c79c84baad7 --- /dev/null +++ b/vendors/irmin/src/irmin-cli/resolver.ml @@ -0,0 +1,732 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Cmdliner +open Astring +module Xgit = Irmin_git_unix +module Http = Irmin_http_unix + +let global_option_section = "COMMON OPTIONS" + +module Conf = Irmin.Backend.Conf + +let try_parse ty v = + match Irmin.Type.of_string ty v with + | Error e -> ( + let x = Format.sprintf "{\"some\": %s}" v in + match Irmin.Type.of_string ty x with + | Error _ -> + let y = Format.sprintf "{\"some\": \"%s\"}" v in + Irmin.Type.of_string ty y |> Result.map_error (fun _ -> e) + | v -> v) + | v -> v + +let pconv t = + let pp = Irmin.Type.pp t in + let parse s = + match try_parse t s with Ok x -> `Ok x | Error (`Msg e) -> `Error e + in + (parse, pp) + +let config_path_term = + let name = "config" in + let doc = "Allows configuration file to be specified on the command-line." in + let docv = "PATH" in + let docs = "COMMON OPTIONS" in + let mk = pconv Irmin.Type.(option string) in + let i = Arg.info ~docv ~docs ~doc [ name ] in + Arg.(value & opt mk None i) + +let root_term = + let name = "root" in + let doc = "The location of the Irmin store on disk." in + let docv = "PATH" in + let docs = "COMMON OPTIONS" in + let mk = pconv Irmin.Type.(option string) in + let i = Arg.info ~docv ~docs ~doc [ name ] in + Arg.(value & opt mk None i) + +let ( / ) = Filename.concat +let global_config_path = "irmin" / "config.yml" + +(* Contents *) + +module Contents = struct + type t = (module Irmin.Contents.S) + + let all = + ref + [ + ("string", (module Irmin.Contents.String : Irmin.Contents.S)); + ("json", (module Irmin.Contents.Json)); + ("json-value", (module Irmin.Contents.Json_value)); + ] + + let default = "string" |> fun n -> ref (n, List.assoc n !all) + + let add name ?default:(x = false) m = + all := (name, m) :: !all; + if x then default := (name, m) + + let find name = + match List.assoc_opt (String.Ascii.lowercase name) !all with + | Some c -> c + | None -> + let valid = String.concat ~sep:", " (List.split !all |> fst) in + let msg = + Printf.sprintf "Invalid content type: %s. Expected one of: %s." name + valid + in + failwith msg + + let term () = + let content_types = !all |> List.map (fun (name, _) -> (name, name)) in + let kind = + let doc = + Fmt.str "The type of user-defined contents (%s). Default is `%s'." + (Arg.doc_alts_enum content_types) + (fst !default) + in + let arg_info = + Arg.info ~doc ~docs:global_option_section [ "contents"; "c" ] + in + Arg.(value & opt (some string) None & arg_info) + in + let create kind = kind in + Term.(const create $ kind) +end + +type contents = Contents.t + +module Hash = struct + type t = (module Irmin.Hash.S) + type hash_function = Fixed of t | Variable_size of (int option -> t) + + module type SIZEABLE = functor + (S : sig + val digest_size : int + end) + -> Irmin.Hash.S + + let variable_size (module Make : SIZEABLE) (module Default : Irmin.Hash.S) = + Variable_size + (function + | Some s -> + (module struct + include Make (struct + let digest_size = s + end) + end : Irmin.Hash.S) + | None -> (module Default)) + + let all = + ref + [ + ( "blake2b", + variable_size + (module Irmin.Hash.Make_BLAKE2B : SIZEABLE) + (module Irmin.Hash.BLAKE2B : Irmin.Hash.S) ); + ( "blake2s", + variable_size + (module Irmin.Hash.Make_BLAKE2S : SIZEABLE) + (module Irmin.Hash.BLAKE2S : Irmin.Hash.S) ); + ("rmd160", Fixed (module Irmin.Hash.RMD160 : Irmin.Hash.S)); + ("sha1", Fixed (module Irmin.Hash.SHA1 : Irmin.Hash.S)); + ("sha224", Fixed (module Irmin.Hash.SHA224 : Irmin.Hash.S)); + ("sha256", Fixed (module Irmin.Hash.SHA256 : Irmin.Hash.S)); + ("sha384", Fixed (module Irmin.Hash.SHA384 : Irmin.Hash.S)); + ("sha512", Fixed (module Irmin.Hash.SHA512 : Irmin.Hash.S)); + ("tezos", Fixed (module Irmin_tezos.Schema.Hash : Irmin.Hash.S)); + ] + + let default = ref ("blake2b", (module Irmin.Hash.BLAKE2B : Irmin.Hash.S)) + + let add name ?default:(x = false) m = + all := (name, Fixed m) :: !all; + if x then default := (name, m) + + let find_hashfn name = + match List.assoc_opt (String.Ascii.lowercase name) !all with + | Some c -> c + | None -> + let valid = String.concat ~sep:", " (List.split !all |> fst) in + let msg = + Printf.sprintf "Invalid hash function: %s. Expected one of: %s." name + valid + in + failwith msg + + let of_specifier hashname = + let ( >>= ) x f = match x with Ok x -> f x | Error _ as e -> e in + (match String.cut ~rev:true ~sep:"/" hashname with + | Some (hashname, size) -> ( + match int_of_string_opt size with + | Some size -> Ok (hashname, Some size) + | None -> Error (`Msg (Fmt.str "Non-numeric hash size %s passed" size))) + | None -> Ok (hashname, None)) + >>= fun (hashname, size_opt) -> + match (find_hashfn hashname, size_opt) with + | Variable_size hashfn, size_opt -> Ok (hashfn size_opt) + | Fixed hashfn, None -> Ok hashfn + | Fixed _, Some size -> + Error + (`Msg + (Fmt.str "Cannot specify a size for hash function `%s' (%d passed)." + hashname size)) + + let find h = + of_specifier h |> function Ok h -> h | Error (`Msg e) -> failwith e + + let hash_function_conv : t Cmdliner.Arg.conv = Arg.conv (of_specifier, Fmt.nop) + + let term () = + let kind = + let quote s = Fmt.str "`%s'" s in + let hash_types = !all |> List.map (fun (name, _) -> (name, name)) in + let variable_size_types = + !all + |> List.filter (function + | _, Variable_size _ -> true + | _, Fixed _ -> false) + |> List.map fst + in + let pp_prose_list = + Fmt.of_to_string (function + | [] -> "" + | [ h ] -> quote h + | hs -> + let rev_hs = List.rev hs in + Fmt.str "%s and %s" + (String.concat ~sep:", " (List.rev_map quote (List.tl rev_hs))) + (quote (List.hd rev_hs))) + in + let pp_plural = + Fmt.of_to_string (function _ :: _ :: _ -> "s" | _ -> "") + in + let pp_variable_size_doc ppf = function + | [] -> () + | _ :: _ as hs -> + Fmt.pf ppf + "\n\ + The bit-length of the hash function%a %a may optionally be set \ + with a trailing slash (e.g. `%s/16')." + pp_plural hs pp_prose_list hs (List.hd hs) + in + let doc = + Fmt.str "The hash function (%s). Default is `%s'.%a" + (Arg.doc_alts_enum hash_types) + (fst !default) pp_variable_size_doc variable_size_types + in + let arg_info = + Arg.info ~doc ~docs:global_option_section [ "hash"; "h" ] + in + Arg.(value & opt (some hash_function_conv) None & arg_info) + in + let create kind = kind in + Term.(const create $ kind) +end + +type hash = Hash.t + +(* Store *) + +module Store = struct + module Impl = struct + type 'a t = + | Hash_keyed : (module Irmin.S with type t = 'a) -> 'a t + | Generic_keyed : (module Irmin.Generic_key.S with type t = 'a) -> 'a t + + let generic_keyed (type a) (t : a t) : + (module Irmin.Generic_key.S with type t = a) = + match t with Hash_keyed (module S) -> (module S) | Generic_keyed x -> x + + let hash_keyed = function Hash_keyed x -> Some x | Generic_keyed _ -> None + end + + type remote_fn = + ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t + + type t = + | T : { + impl : _ Impl.t; + spec : Irmin.Backend.Conf.Spec.t; + remote : remote_fn option; + } + -> t + + let spec (T { spec; _ }) = spec + + type store_functor = + | Fixed_hash of (contents -> t) + | Variable_hash of (hash -> contents -> t) + | Fixed of t + + module type G = sig + include Irmin.S + + val remote : remote_fn + end + + let v ?remote spec s = T { impl = Impl.Hash_keyed s; spec; remote } + let v_generic ?remote spec s = T { impl = Impl.Generic_keyed s; spec; remote } + let v_git (module S : G) = v Irmin_git.Conf.spec (module S) ~remote:S.remote + + let create : + Irmin.Backend.Conf.Spec.t -> (module Irmin.Maker) -> hash -> contents -> t + = + fun spec (module S) (module H) (module C) -> + let module Schema = struct + include Irmin.Schema.KV (C) + module Hash = H + end in + let module S = S.Make (Schema) in + v spec (module S) + + let mem = create Irmin_mem.Conf.spec (module Irmin_mem) + let irf = create Irmin_fs.Conf.spec (module Irmin_fs_unix) + + let http = function + | T { impl = Generic_keyed _; _ } -> + Fmt.failwith + "Unsupported backend: can't build an HTTP server over a store that \ + is not keyed by hashes" + | T { impl = Hash_keyed (module S); spec; remote } -> + T + { + impl = Hash_keyed (module Http.Client (S)); + spec = Irmin.Backend.Conf.Spec.join spec [ Irmin_http.Conf.spec ]; + remote; + } + + let git (module C : Irmin.Contents.S) = v_git (module Xgit.FS.KV (C)) + let git_mem (module C : Irmin.Contents.S) = v_git (module Xgit.Mem.KV (C)) + + module Irmin_pack_maker : Irmin.Generic_key.Maker = struct + include Irmin_pack_unix.Maker (Irmin_tezos.Conf) + + module Make (Schema : Irmin.Schema.S) = Make (struct + include Schema + module Node = Irmin.Node.Generic_key.Make (Hash) (Path) (Metadata) + module Commit_maker = Irmin.Commit.Generic_key.Maker (Info) + module Commit = Commit_maker.Make (Hash) + end) + end + + let pack : hash -> contents -> t = + fun (module H) (module C) -> + let module Schema = struct + include Irmin.Schema.KV (C) + module Hash = H + end in + v_generic Irmin_pack.Conf.spec (module Irmin_pack_maker.Make (Schema)) + + let tezos = v_generic Irmin_pack.Conf.spec (module Irmin_tezos.Store) + + let all = + ref + [ + ("git", Fixed_hash git); + ("git-mem", Fixed_hash git_mem); + ("irf", Variable_hash irf); + ("mem", Variable_hash mem); + ("mem-http", Variable_hash (fun h c -> http (mem h c))); + ("git-http", Fixed_hash (fun c -> http (git c))); + ("pack", Variable_hash pack); + ("tezos", Fixed tezos); + ] + + let default = "git" |> fun n -> ref (n, List.assoc n !all) + + let add name ?default:(x = false) m = + all := (name, m) :: !all; + if x then default := (name, m) + + let find name = + match List.assoc_opt (String.Ascii.lowercase name) !all with + | Some s -> s + | None -> + let valid = String.concat ~sep:", " (List.split !all |> fst) in + let msg = + Printf.sprintf "Invalid store type: %s. Expected one of: %s." name + valid + in + failwith msg + + let generic_keyed = function + | T { impl = Generic_keyed (module S); _ } -> + (module S : Irmin.Generic_key.S) + | T { impl = Hash_keyed (module S); _ } -> (module S : Irmin.Generic_key.S) + + let hash_keyed = function + | T { impl = Generic_keyed (module S); _ } -> None + | T { impl = Hash_keyed (module S); _ } -> Some (module S : Irmin.S) + + let remote (T { remote; _ }) = remote + + let term () = + let store = + let store_types = !all |> List.map (fun (name, _) -> (name, name)) in + let doc = + Fmt.str "The storage backend (%s). Default is `%s'." + (Arg.doc_alts_enum store_types) + (fst !default) + in + let arg_info = + Arg.info ~doc ~docs:global_option_section [ "s"; "store" ] + in + Arg.(value & opt (some string) None & arg_info) + in + let create store hash contents = (store, hash, contents) in + Term.(const create $ store $ Hash.term () $ Contents.term ()) +end + +(* Config *) + +let home = + try Sys.getenv "HOME" + with Not_found -> ( + try (Unix.getpwuid (Unix.getuid ())).Unix.pw_dir + with Unix.Unix_error _ | Not_found -> + if Sys.win32 then try Sys.getenv "AppData" with Not_found -> "" else "") + +let config_root () = + try Sys.getenv "XDG_CONFIG_HOME" + with Not_found -> + if Sys.win32 then home / "Local Settings" else home / ".config" + +let config_term = + let create root config_path (opts : (string * string) list list) = + (root, config_path, opts) + in + let doc = + "Backend-specific options. See the output of `irmin options` for a list of \ + options supported by the selected backend" + in + let opts = + Arg.info ~docv:"OPTIONS" ~docs:global_option_section ~doc + [ "opt"; "options" ] + in + Term.( + const create + $ root_term + $ config_path_term + $ Arg.(value @@ opt_all (list (pair ~sep:'=' string string)) [] opts)) + +type store = S : 'a Store.Impl.t * 'a Lwt.t * Store.remote_fn option -> store + +let rec read_config_file path = + let home = config_root () / global_config_path in + let path = + match path with + | Some path -> + if (not (Sys.file_exists path)) && not (String.equal path home) then + Fmt.failwith "config file does not exist: %s" path + else path + | None -> "irmin.yml" + in + let global = + if String.equal path home then `O [] else read_config_file (Some home) + in + if not (Sys.file_exists path) then global + else + let () = [%logs.debug "Loading config from file: %s" path] in + let oc = open_in path in + let len = in_channel_length oc in + let buf = really_input_string oc len in + close_in oc; + if Astring.String.(is_empty (trim buf)) then `O [] + else + match Yaml.of_string buf with + | Ok (`O _ as y) -> Yaml.Util.combine_exn y global + | Ok `Null -> global + | Ok _ -> Fmt.failwith "invalid YAML file: %s" path + | Error (`Msg msg) -> Fmt.failwith "unable to parse YAML: %s" msg + +let rec json_of_yaml : Yaml.value -> Yojson.Basic.t = function + | `O x -> `Assoc (List.map (fun (k, v) -> (k, json_of_yaml v)) x) + | `A x -> `List (List.map json_of_yaml x) + | (`Null | `Bool _ | `Float _ | `String _) as x -> x + +let parse_config ?root y spec = + let config = Conf.empty spec in + (* Initialise root for the examples in README to pass. *) + let config = Conf.add config (Conf.root spec) "." in + let config = + List.fold_left + (fun config k -> + match (Conf.Spec.find_key spec k, Yaml.Util.find_exn k y) with + | Some (Irmin.Backend.Conf.K k), Some v -> + let v = json_of_yaml v |> Yojson.Basic.to_string in + let v = + match Irmin.Type.of_json_string (Conf.ty k) v with + | Error _ -> + let v = Format.sprintf "{\"some\": %s}" v in + Irmin.Type.of_json_string (Conf.ty k) v |> Result.get_ok + | Ok v -> v + in + Conf.add config k v + | None, _ -> ( + match k with + | "contents" | "hash" | "store" | "plugin" -> config + | _ -> + Fmt.invalid_arg "unknown config key for %s: %s" + (Conf.Spec.name spec) k) + | _ -> config) + config (Yaml.Util.keys_exn y) + in + let config = + match (root, Conf.Spec.find_key spec "root") with + | Some root, Some (K r) -> + let v = Irmin.Type.of_string (Conf.ty r) root |> Result.get_ok in + Conf.add config r v + | _ -> config + in + config + +let load_plugin ?plugin config = + match plugin with + | Some p -> Dynlink.loadfile_private p + | None -> ( + match Yaml.Util.find "plugin" config with + | Ok (Some v) -> Dynlink.loadfile_private (Yaml.Util.to_string_exn v) + | _ -> ()) + +let get_store ?plugin config (store, hash, contents) = + let () = load_plugin ?plugin config in + let store = + match store with + | Some s -> Store.find s + | None -> ( + match Yaml.Util.find_exn "store" config with + | Some (`String s) -> ( + match store with Some s -> Store.find s | None -> Store.find s) + | _ -> snd !Store.default) + in + let contents = + match contents with + | Some s -> Contents.find s + | None -> ( + match Yaml.Util.find_exn "contents" config with + | Some (`String s) -> Contents.find s + | _ -> snd !Contents.default) + in + let hash = + match hash with + | Some s -> Some s + | None -> ( + match Yaml.Util.find_exn "hash" config with + | Some (`String s) -> Some (Hash.find s) + | _ -> None) + in + match store with + | Variable_hash s -> + let hash : Hash.t = Option.value ~default:(snd !Hash.default) hash in + s hash contents + | Fixed_hash s -> ( + (* error if a hash function has been passed *) + match hash with + | None -> s contents + | _ -> + Fmt.failwith "Cannot customize the hash function for the given store") + | Fixed s -> ( + match hash with + | None -> s + | _ -> + Fmt.failwith "Cannot customize the hash function for the given store") + +let load_config ?plugin ?root ?config_path ?store ?hash ?contents () = + let y = read_config_file config_path in + let store = get_store ?plugin y (store, hash, contents) in + let spec = Store.spec store in + let config = parse_config ?root y spec in + (store, config) + +let string_value = function `String s -> s | _ -> raise Not_found + +let find_key config name = + Yaml.Util.find_exn name config |> Option.map (fun x -> string_value x) + +let handle_decode_err err t x = + match Irmin.Type.of_string t x with Ok h -> h | _ -> invalid_arg err + +let get_branch (type a) + (module S : Irmin.Generic_key.S with type Schema.Branch.t = a) config branch + = + let of_string = Option.map (handle_decode_err "invalid branch" S.Branch.t) in + match branch with + | None -> of_string (find_key config "branch") + | Some t -> of_string (Some t) + +let get_commit (type a b) + (module S : Irmin.Generic_key.S + with type commit = a + and type Schema.Hash.t = b) config commit = + let of_string = Option.map (handle_decode_err "invalid commit" S.Hash.t) in + match commit with + | None -> of_string (find_key config "commit") + | Some t -> of_string (Some t) + +let build_irmin_config config root opts (store, hash, contents) branch commit + plugin : store = + let (T { impl; spec; remote }) = + get_store ?plugin config (store, hash, contents) + in + let (module S) = Store.Impl.generic_keyed impl in + let branch = get_branch (module S) config branch in + let commit = get_commit (module S) config commit in + let config = parse_config ?root config spec in + let config = + List.fold_left + (fun config (k, v) -> + let (Irmin.Backend.Conf.K key) = + if k = "root" then + invalid_arg + "use the --root flag to set the root directory instead of \ + passing it as a config" + else + match Conf.Spec.find_key spec k with + | Some x -> x + | None -> invalid_arg ("opt: " ^ k) + in + let ty = Conf.ty key in + let v = try_parse ty v |> Result.get_ok in + let config = Conf.add config key v in + config) + config (List.flatten opts) + in + let spec = + match (branch, commit) with + | _, Some hash -> ( + S.Repo.v config >>= fun repo -> + let* commit = S.Commit.of_hash repo hash in + match commit with + | None -> invalid_arg "unknown commit" + | Some c -> S.of_commit c) + | None, None -> S.Repo.v config >>= S.main + | Some b, None -> S.Repo.v config >>= fun repo -> S.of_branch repo b + in + S (impl, spec, remote) + +let branch = + let doc = + Arg.info ~doc:"The current branch name. Default is the store's main branch." + ~docs:global_option_section ~docv:"BRANCH" [ "b"; "branch" ] + in + Arg.(value & opt (some string) None & doc) + +let commit = + let doc = + Arg.info + ~doc:"The store's head commit. This will take precedence over --branch." + ~docs:global_option_section ~docv:"COMMIT" [ "commit" ] + in + Arg.(value & opt (some string) None & doc) + +let plugin = + let doc = "Register new contents, store or hash types" in + Arg.(value & opt (some string) None & info ~doc [ "plugin" ]) + +let store () = + let create plugin store (root, config_path, opts) branch commit = + let y = read_config_file config_path in + build_irmin_config y root opts store branch commit plugin + in + Term.(const create $ plugin $ Store.term () $ config_term $ branch $ commit) + +let header_conv = + let parse str = + match String.cut ~sep:":" str with + | Some (k, v) -> Ok (String.trim k, String.trim v) + | None -> Error (`Msg "invalid header") + in + let print ppf (k, v) = Fmt.pf ppf "%s: %s" k v in + Cmdliner.Arg.conv (parse, print) + +let headers = + let doc = + Arg.info ~docv:"HEADER" ~doc:"Extra HTTP headers to use when sync." [ "H" ] + in + Arg.(value & opt_all header_conv [] & doc) + +type Irmin.remote += R of Cohttp.Header.t option * string + +(* FIXME: this is a very crude heuristic to choose the remote + kind. Would be better to read the config file and look for remote + alias. *) +let infer_remote hash contents branch headers str = + let hash = match hash with None -> snd !Hash.default | Some c -> c in + let contents = + match contents with + | None -> snd !Contents.default + | Some c -> Contents.find c + in + if Sys.file_exists str then + let r = + if Sys.file_exists (str / ".git") then Store.git contents + else if Sys.file_exists (str / "store.dict") then Store.pack hash contents + else Store.irf hash contents + in + match r with + | Store.T { impl; spec; _ } -> + let (module R) = Store.Impl.generic_keyed impl in + let config = Conf.empty spec in + let config = + match Conf.Spec.find_key spec "root" with + | Some (K r) -> + let v = Irmin.Type.of_string (Conf.ty r) str |> Result.get_ok in + Conf.add config r v + | _ -> config + in + let* repo = R.Repo.v config in + let branch = + match branch with + | Some b -> Irmin.Type.of_string R.branch_t b |> Result.get_ok + | None -> R.Branch.main + in + let+ r = R.of_branch repo branch in + Irmin.remote_store (module R) r + else + let headers = + match headers with [] -> None | h -> Some (Cohttp.Header.of_list h) + in + Lwt.return (R (headers, str)) + +let remote () = + let repo = + let doc = + Arg.info ~docv:"REMOTE" + ~doc:"The URI of the remote repository to clone from." [] + in + Arg.(required & pos 0 (some string) None & doc) + in + let create (store, hash, contents) (root, config_path, opts) branch commit + headers str = + let y = read_config_file config_path in + let store = + build_irmin_config y root opts (store, hash, contents) branch commit None + in + let remote = infer_remote hash contents branch headers str in + (store, remote) + in + Term.( + const create + $ Store.term () + $ config_term + $ branch + $ commit + $ headers + $ repo) diff --git a/vendors/irmin/src/irmin-cli/resolver.mli b/vendors/irmin/src/irmin-cli/resolver.mli new file mode 100644 index 0000000000000000000000000000000000000000..783d995c259b35f93c264c894cd28e03fa3691f0 --- /dev/null +++ b/vendors/irmin/src/irmin-cli/resolver.mli @@ -0,0 +1,135 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Irmin store resolver. *) + +val global_option_section : string +val branch : string option Cmdliner.Term.t + +(** {1 Hash} *) +module Hash : sig + type t = (module Irmin.Hash.S) + + val add : string -> ?default:bool -> (module Irmin.Hash.S) -> unit + val find : string -> t + val term : unit -> t option Cmdliner.Term.t +end + +type hash = Hash.t + +(** {1 Contents} *) +module Contents : sig + type t = (module Irmin.Contents.S) + + val add : string -> ?default:bool -> (module Irmin.Contents.S) -> unit + val find : string -> t + val term : unit -> string option Cmdliner.Term.t +end + +type contents = Contents.t + +(** {1 Global Configuration} *) + +module Store : sig + module Impl : sig + (** The type of {i implementations} of an Irmin store. + + Stores can be either keyed by hashes or by some other abstract type. In + the latter case, the store implementation cannot be used to build HTTP / + GraphQL servers using [irmin-unix]. This limitation may be lifted in a + future version of [irmin-unix]. *) + type 'a t = + | Hash_keyed : (module Irmin.S with type t = 'a) -> 'a t + | Generic_keyed : (module Irmin.Generic_key.S with type t = 'a) -> 'a t + + val generic_keyed : 'a t -> (module Irmin.Generic_key.S with type t = 'a) + val hash_keyed : 'a t -> (module Irmin.S with type t = 'a) option + end + + type remote_fn = + ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t + + type t + (** The type for store configurations. A configuration value contains: the + store implementation a creator of store's state and endpoint. *) + + type store_functor = + | Fixed_hash of (contents -> t) + | Variable_hash of (hash -> contents -> t) + | Fixed of t + (** The type of constructors of a store configuration. Depending on the + backend, a store may require a hash function. *) + + val v : + ?remote:remote_fn -> + Irmin.Backend.Conf.Spec.t -> + (module Irmin.S with type t = _) -> + t + + val v_generic : + ?remote:remote_fn -> + Irmin.Backend.Conf.Spec.t -> + (module Irmin.Generic_key.S with type t = _) -> + t + + val mem : hash -> contents -> t + val irf : hash -> contents -> t + val http : t -> t + val git : contents -> t + val pack : hash -> contents -> t + val find : string -> store_functor + val add : string -> ?default:bool -> store_functor -> unit + val spec : t -> Irmin.Backend.Conf.Spec.t + val generic_keyed : t -> (module Irmin.Generic_key.S) + val hash_keyed : t -> (module Irmin.S) option + val remote : t -> remote_fn option + + val term : + unit -> (string option * hash option * string option) Cmdliner.Term.t +end + +(** {1 Stores} *) + +val load_config : + ?plugin:string -> + ?root:string -> + ?config_path:string -> + ?store:string -> + ?hash:hash -> + ?contents:string -> + unit -> + Store.t * Irmin.config +(** Load config file from disk + + [plugin] is the path to an OCaml plugin in cmxs format to be loaded at + runtime + + [config_path] can be used to specify the location of a configuration file. + + [root] is used to specify the path of the store. + + The values provided for [store], [hash] and [contents] will be used by + default if no other value is found in the config file *) + +type store = S : 'a Store.Impl.t * 'a Lwt.t * Store.remote_fn option -> store + +val store : unit -> store Cmdliner.Term.t +(** Parse the command-line arguments and then the config file. *) + +type Irmin.remote += R of Cohttp.Header.t option * string + +val remote : unit -> (store * Irmin.remote Lwt.t) Cmdliner.Term.t +(** Parse a remote store location. *) diff --git a/vendors/irmin/src/irmin-containers/blob_log.ml b/vendors/irmin/src/irmin-containers/blob_log.ml new file mode 100644 index 0000000000000000000000000000000000000000..722284ab16b8e3918854559049c8e303b8da5972 --- /dev/null +++ b/vendors/irmin/src/irmin-containers/blob_log.ml @@ -0,0 +1,81 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module Blob_log (T : Time.S) (V : Irmin.Type.S) : + Irmin.Contents.S with type t = (V.t * T.t) list = struct + type t = (V.t * T.t) list [@@deriving irmin] + + let compare_t = Irmin.Type.(unstage (compare T.t)) + let compare (_, t1) (_, t2) = compare_t t1 t2 + + let newer_than timestamp entries = + let rec util acc = function + | [] -> List.rev acc + | (_, x) :: _ when compare_t x timestamp <= 0 -> List.rev acc + | h :: t -> util (h :: acc) t + in + util [] entries + + let merge ~old v1 v2 = + let open Irmin.Merge.Infix in + let ok = Irmin.Merge.ok in + old () >>=* fun old -> + let old = match old with None -> [] | Some o -> o in + let l1, l2 = + match old with + | [] -> (v1, v2) + | (_, t) :: _ -> (newer_than t v1, newer_than t v2) + in + let l3 = List.sort compare (List.rev_append l1 l2) in + ok (List.rev_append l3 old) + + let merge = Irmin.Merge.(option (v t merge)) +end + +module type S = sig + module Store : Irmin.KV + + type value + + val append : path:Store.path -> Store.t -> value -> unit Lwt.t + val read_all : path:Store.path -> Store.t -> value list Lwt.t +end + +module Make (Backend : Irmin.KV_maker) (T : Time.S) (V : Irmin.Type.S) = struct + module Store = Backend.Make (Blob_log (T) (V)) + + let empty_info = Store.Info.none + + type value = V.t + + let create_entry v = (v, T.now ()) + + let append ~path t v = + Store.find t path >>= function + | None -> Store.set_exn ~info:empty_info t path [ create_entry v ] + | Some l -> Store.set_exn ~info:empty_info t path (create_entry v :: l) + + let read_all ~path t = + Store.find t path >|= function + | None -> [] + | Some l -> List.map (fun (v, _) -> v) l +end + +module FS (V : Irmin.Type.S) = Make (Irmin_fs_unix.KV) (Time.Machine) (V) +module Mem (V : Irmin.Type.S) = Make (Irmin_mem.KV) (Time.Machine) (V) diff --git a/vendors/irmin/src/irmin-containers/blob_log.mli b/vendors/irmin/src/irmin-containers/blob_log.mli new file mode 100644 index 0000000000000000000000000000000000000000..6ac444dc0b3344d7cfeb3777cb87745ce52121c7 --- /dev/null +++ b/vendors/irmin/src/irmin-containers/blob_log.mli @@ -0,0 +1,54 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** The implementation of log in which it is maintained as a single unit, or + blob. Hence, two versions of the log cannot share their common predecessor. + The type of values to be stored as well as a method to obtain timestamps are + provided by the user. + + Merging does the following: the newer entries from each branch, with respect + to the least common ancestor, are taken, merged and then appended in front + of the LCA. *) + +(** Signature of [Blob_log] *) +module type S = sig + module Store : Irmin.KV + (** Store for the log. All store related operations like branching, cloning, + merging, etc are done through this module. *) + + type value + (** Type of log entry *) + + val append : path:Store.path -> Store.t -> value -> unit Lwt.t + (** Append an entry to the log *) + + val read_all : path:Store.path -> Store.t -> value list Lwt.t + (** Read the entire log *) +end + +(** [Make] returns a mergeable blob log using the backend and other parameters + as specified by the user. *) +module Make (Backend : Irmin.KV_maker) (T : Time.S) (V : Irmin.Type.S) : + S with type value = V.t + +(** Blob log instantiated using the {{!Irmin_fs_unix} FS backend} provided by + [Irmin_fs_unix] and the timestamp method {!Time.Unix} *) +module FS (V : Irmin.Type.S) : S with type value = V.t + +(** Blob log instantiated using the {{!Irmin_mem} in-memory backend} provided by + [Irmin_mem] and the timestamp method {!Time.Unix} *) +module Mem (V : Irmin.Type.S) : S with type value = V.t diff --git a/vendors/irmin/src/irmin-containers/counter.ml b/vendors/irmin/src/irmin-containers/counter.ml new file mode 100644 index 0000000000000000000000000000000000000000..148f797771de2671db6d9f528aea945d46fdceed --- /dev/null +++ b/vendors/irmin/src/irmin-containers/counter.ml @@ -0,0 +1,59 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module Counter : Irmin.Contents.S with type t = int64 = struct + type t = int64 + + let t = Irmin.Type.int64 + let merge = Irmin.Merge.(option counter) +end + +module type S = sig + module Store : Irmin.KV + + val inc : + ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit Lwt.t + + val dec : + ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit Lwt.t + + val read : path:Store.path -> Store.t -> int64 Lwt.t +end + +module Make (Backend : Irmin.KV_maker) = struct + module Store = Backend.Make (Counter) + + let empty_info = Store.Info.none + + let modify by info t path fn = + Store.find t path >>= function + | None -> Store.set_exn ~info t path (fn 0L by) + | Some v -> Store.set_exn ~info t path (fn v by) + + let inc ?(by = 1L) ?(info = empty_info) ~path t = + modify by info t path (fun x by -> Int64.add x by) + + let dec ?(by = 1L) ?(info = empty_info) ~path t = + modify by info t path (fun x by -> Int64.sub x by) + + let read ~path t = Store.find t path >|= function None -> 0L | Some v -> v +end + +module FS = Make (Irmin_fs_unix.KV) +module Mem = Make (Irmin_mem.KV) diff --git a/vendors/irmin/src/irmin-containers/counter.mli b/vendors/irmin/src/irmin-containers/counter.mli new file mode 100644 index 0000000000000000000000000000000000000000..4759a7f5c22b2467e7acb39344262e9e4f3bed40 --- /dev/null +++ b/vendors/irmin/src/irmin-containers/counter.mli @@ -0,0 +1,54 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** The implementation of an [int64] counter. This module supports operations to + increment, decrement and read the value of the counter. + + Merge semantics is as follows: if [old] is the value of the LCA and [v1] and + [v2] are the current values, then the merged value is [v1 + v2 - old]. *) + +(** Counter signature *) +module type S = sig + module Store : Irmin.KV + (** Content store of counter. All store related operations like branching, + cloning, merging, etc are done through this module. *) + + val inc : + ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit Lwt.t + (** Increment the counter by the amount specified using [by]. If no value is + specified, then [by] is assigned the value 1L. *) + + val dec : + ?by:int64 -> ?info:Store.Info.f -> path:Store.path -> Store.t -> unit Lwt.t + (** Decrement the counter by the amount specified using [by]. If no value is + specified, then [by] is assigned the value 1L. *) + + val read : path:Store.path -> Store.t -> int64 Lwt.t + (** Read the value of the counter *) +end + +(** [Make] returns a mergeable counter using the backend and other parameters as + specified by the user. *) +module Make (Backend : Irmin.KV_maker) : S + +module FS : S +(** Counter instantiated using the {{!Irmin_fs_unix} FS backend} provided by + [Irmin_fs_unix] *) + +module Mem : S +(** Counter instantiated using the {{!Irmin_mem} in-memory backend} provided by + [Irmin_mem] *) diff --git a/vendors/irmin/src/irmin-containers/dune b/vendors/irmin/src/irmin-containers/dune new file mode 100644 index 0000000000000000000000000000000000000000..c0271dfd7251152d408f59edda025002456c52f2 --- /dev/null +++ b/vendors/irmin/src/irmin-containers/dune @@ -0,0 +1,8 @@ +(library + (name irmin_containers) + (public_name irmin-containers) + (libraries irmin irmin.mem irmin-fs.unix mtime mtime.clock.os) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-containers/import.ml b/vendors/irmin/src/irmin-containers/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..2a449bdd3b774233670483879d30e1313017542f --- /dev/null +++ b/vendors/irmin/src/irmin-containers/import.ml @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends +module FS = Irmin_fs_unix diff --git a/vendors/irmin/src/irmin-containers/irmin_containers.ml b/vendors/irmin/src/irmin-containers/irmin_containers.ml new file mode 100644 index 0000000000000000000000000000000000000000..313bd7847fbcff3a45a16c5ebebaa735e3f91497 --- /dev/null +++ b/vendors/irmin/src/irmin-containers/irmin_containers.ml @@ -0,0 +1,47 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [Irmin_containers] is a collection of simple, ready-to-use mergeable data + structures. Each data structure works with an arbitrary Irmin backend and is + customisable in a variety of ways. + + Additionally, [Irmin_containers] supplies instantiations of each of these + data structures with two backends: + + - the {{!Irmin_mem} in-memory backend} provided by {!Irmin_mem} + - the {{!Irmin_fs_unix} FS backend} provided by {!Irmin_fs_unix}. *) + +(** {1 Data structures} *) + +module Counter = Counter +module Lww_register = Lww_register +module Blob_log = Blob_log +module Linked_log = Linked_log + +(** {1 Auxiliary signatures and modules} *) + +(** [Store_maker] is the signature for the backend input to the data structures. + The Irmin stores of the data structures are constructed using modules of + this type *) + +module type Content_addressable = Stores.Content_addressable + +(** [Cas_maker] is the signature for the store which will be used to maintain + linked data structures. The elements are hashed into this store and the hash + value is used to construct the linkages. *) + +module Time = Time diff --git a/vendors/irmin/src/irmin-containers/linked_log.ml b/vendors/irmin/src/irmin-containers/linked_log.ml new file mode 100644 index 0000000000000000000000000000000000000000..8ba08b1b567df06acefef008f5289bc278616793 --- /dev/null +++ b/vendors/irmin/src/irmin-containers/linked_log.ml @@ -0,0 +1,168 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module Log_item (T : Time.S) (H : Irmin.Hash.S) (V : Irmin.Type.S) = struct + type t = { time : T.t; msg : V.t; prev : H.t option } [@@deriving irmin] +end + +module Store_item (T : Time.S) (H : Irmin.Hash.S) (V : Irmin.Type.S) = struct + module L = Log_item (T) (H) (V) + + type t = Value of L.t | Merge of L.t list [@@deriving irmin] +end + +module Linked_log + (C : Stores.Content_addressable) + (T : Time.S) + (H : Irmin.Hash.S) + (V : Irmin.Type.S) = +struct + type t = H.t [@@deriving irmin] + + module L = Log_item (T) (H) (V) + module S = Store_item (T) (H) (V) + + module Store = struct + module CAS = C.Make (H) (Store_item (T) (H) (V)) + + let get_store = + let st = CAS.v @@ C.config in + fun () -> st + + let read st k = CAS.find st k + + let read_exn st k = + CAS.find st k >>= function + | None -> Lwt.fail_with "key not found in the store" + | Some v -> Lwt.return v + + let add st v = CAS.batch st (fun t -> CAS.add t v) + end + + let append prev msg = + let* store = Store.get_store () in + Store.add store (Value { time = T.now (); msg; prev }) + + let read_key k = + let* store = Store.get_store () in + Store.read_exn store k + + let compare_t = Irmin.Type.(unstage (compare T.t)) + let sort l = List.sort (fun i1 i2 -> compare_t i2.L.time i1.L.time) l + + let merge ~old:_ v1 v2 = + let open Irmin.Merge in + let* store = Store.get_store () in + let* v1 = Store.read store v1 in + let* v2 = Store.read store v2 in + let convert_to_list = function + | None -> [] + | Some (S.Value v) -> [ v ] + | Some (S.Merge lv) -> lv + in + let lv1 = convert_to_list v1 in + let lv2 = convert_to_list v2 in + Store.add store (S.Merge (sort @@ lv1 @ lv2)) >>= ok + + let merge = Irmin.Merge.(option (v t merge)) +end + +module type S = sig + include Blob_log.S + + type cursor + + val get_cursor : path:Store.path -> Store.t -> cursor Lwt.t + val read : num_items:int -> cursor -> (value list * cursor) Lwt.t +end + +module Make + (Backend : Irmin.KV_maker) + (C : Stores.Content_addressable) + (T : Time.S) + (H : Irmin.Hash.S) + (V : Irmin.Type.S) + () = +struct + module L = Linked_log (C) (T) (H) (V) + module Store = Backend.Make (L) + + module Set_elt = struct + type t = H.t + + let compare = Irmin.Type.(unstage (compare H.t)) + end + + module HashSet = Set.Make (Set_elt) + + type value = V.t + + type cursor = { + seen : HashSet.t; + cache : Log_item(T)(H)(V).t list; + store : Store.t; + } + + let empty_info = Store.Info.none + + let append ~path t e = + let* prev = Store.find t path in + let* v = L.append prev e in + Store.set_exn ~info:empty_info t path v + + let get_cursor ~path store = + let mk_cursor seen cache = { seen; cache; store } in + Store.find store path >>= function + | None -> Lwt.return (mk_cursor HashSet.empty []) + | Some k -> ( + L.read_key k >|= function + | Value v -> mk_cursor (HashSet.singleton k) [ v ] + | Merge l -> mk_cursor (HashSet.singleton k) l) + + let rec read_log cursor num_items acc = + if num_items <= 0 then Lwt.return (List.rev acc, cursor) + else + match cursor.cache with + | [] -> Lwt.return (List.rev acc, cursor) + | { msg; prev = None; _ } :: xs -> + read_log { cursor with cache = xs } (num_items - 1) (msg :: acc) + | { msg; prev = Some pk; _ } :: xs -> ( + if HashSet.mem pk cursor.seen then + read_log { cursor with cache = xs } (num_items - 1) (msg :: acc) + else + let seen = HashSet.add pk cursor.seen in + L.read_key pk >>= function + | Value v -> + read_log + { cursor with seen; cache = L.sort (v :: xs) } + (num_items - 1) (msg :: acc) + | Merge l -> + read_log + { cursor with seen; cache = L.sort (l @ xs) } + (num_items - 1) (msg :: acc)) + + let read ~num_items cursor = read_log cursor num_items [] + let read_all ~path t = get_cursor t ~path >>= read ~num_items:max_int >|= fst +end + +module FS (C : Stores.Content_addressable) (V : Irmin.Type.S) () = + Make (Irmin_fs_unix.KV) (C) (Time.Machine) (Irmin.Hash.SHA1) (V) () + +module Mem (C : Stores.Content_addressable) (V : Irmin.Type.S) () = + Make (Irmin_mem.KV) (C) (Time.Machine) (Irmin.Hash.SHA1) (V) () diff --git a/vendors/irmin/src/irmin-containers/linked_log.mli b/vendors/irmin/src/irmin-containers/linked_log.mli new file mode 100644 index 0000000000000000000000000000000000000000..4c6f05084a3a054869ce12a2aa1a95697de2974b --- /dev/null +++ b/vendors/irmin/src/irmin-containers/linked_log.mli @@ -0,0 +1,61 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** The linked list implementation of log. Due to the linked property, two + versions of the log share their common predecessor. As it is a linked data + structure, a content addressable store is required. Along with that, a + method to obtain timestamps, a hash for the content addressable store and + the type of values stored must also be provided. *) + +(** Signature of [Linked_log] *) +module type S = sig + include Blob_log.S + (** @inline *) + + type cursor + (** Type of cursor. Cursor is like a marker from which a certain number of + entries can be read *) + + val get_cursor : path:Store.path -> Store.t -> cursor Lwt.t + (** Create a new cursor over the log entires at the given path *) + + val read : num_items:int -> cursor -> (value list * cursor) Lwt.t + (** Read at most [num_items] entries from the cursor. If the number specified + is greater than the number of log entries from the cursor, the log is read + till the end. If the input cursor has already reached the end, then an + empty list is returned *) +end + +(** [Make] returns a mergeable linked log using the backend and other parameters + as specified by the user. *) +module Make + (Backend : Irmin.KV_maker) + (C : Stores.Content_addressable) + (T : Time.S) + (H : Irmin.Hash.S) + (V : Irmin.Type.S) + () : S with type value = V.t + +(** Linked log instantiated using the {{!Irmin_fs_unix} FS backend} provided by + [Irmin_fs_unix], timestamp method {!Time.Unix} and hash {!Irmin.Hash.SHA1} *) +module FS (C : Stores.Content_addressable) (V : Irmin.Type.S) () : + S with type value = V.t + +(** Linked log instantiated using the {{!Irmin_mem} in-memory backend} provided + by [Irmin_mem], timestamp method {!Time.Unix} and hash {!Irmin.Hash.SHA1} *) +module Mem (C : Stores.Content_addressable) (V : Irmin.Type.S) () : + S with type value = V.t diff --git a/vendors/irmin/src/irmin-containers/lww_register.ml b/vendors/irmin/src/irmin-containers/lww_register.ml new file mode 100644 index 0000000000000000000000000000000000000000..8c5ed1b1a8fcd91262da8db1814d1440d375c4dc --- /dev/null +++ b/vendors/irmin/src/irmin-containers/lww_register.ml @@ -0,0 +1,65 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module LWW (T : Time.S) (V : Irmin.Type.S) : + Irmin.Contents.S with type t = V.t * T.t = struct + type t = V.t * T.t [@@deriving irmin] + + let compare_t = Irmin.Type.(unstage (compare T.t)) + let compare_v = Irmin.Type.(unstage (compare V.t)) + + let compare (v1, t1) (v2, t2) = + let res = compare_t t1 t2 in + if res = 0 then compare_v v1 v2 else res + + let merge ~old:_ v1 v2 = + let open Irmin.Merge in + if compare v1 v2 > 0 then ok v1 else ok v2 + + let merge = Irmin.Merge.(option (v t merge)) +end + +module type S = sig + module Store : Irmin.KV + + type value + + val read : path:Store.path -> Store.t -> value option Lwt.t + + val write : + ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit Lwt.t +end + +module Make (Backend : Irmin.KV_maker) (T : Time.S) (V : Irmin.Type.S) = struct + module Store = Backend.Make (LWW (T) (V)) + + let empty_info = Store.Info.none + + type value = V.t + + let read ~path t = + Store.find t path >|= function None -> None | Some (v, _) -> Some v + + let write ?(info = empty_info) ~path t v = + let timestamp = T.now () in + Store.set_exn ~info t path (v, timestamp) +end + +module FS (V : Irmin.Type.S) = Make (Irmin_fs_unix.KV) (Time.Machine) (V) +module Mem (V : Irmin.Type.S) = Make (Irmin_mem.KV) (Time.Machine) (V) diff --git a/vendors/irmin/src/irmin-containers/lww_register.mli b/vendors/irmin/src/irmin-containers/lww_register.mli new file mode 100644 index 0000000000000000000000000000000000000000..ac8851a35bbf26ab86ef7bdcb1a91879a96b61ec --- /dev/null +++ b/vendors/irmin/src/irmin-containers/lww_register.mli @@ -0,0 +1,53 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** The implementation of last-write-wins register. The value to be stored in + the register and the timestamp method are provided by the user. + + Merge semantics: The value with the largest timestamp is chosen. If two + values have the same timestamp, then the larger value is selected based on + the compare specified by the user. *) + +(** Signature of [Lww_register] *) +module type S = sig + module Store : Irmin.KV + (** Content store of the register. All store related operations like + branching, cloning, merging, etc are done through this module. *) + + type value + (** Type of values stored in the register *) + + val read : path:Store.path -> Store.t -> value option Lwt.t + (** Reads the value from the register. Returns [None] if no value is written *) + + val write : + ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit Lwt.t + (** Writes the provided value to the register *) +end + +(** [Make] returns a mergeable last-write-wins register using the backend and + other parameters as specified by the user. *) +module Make (Backend : Irmin.KV_maker) (T : Time.S) (V : Irmin.Type.S) : + S with type value = V.t + +(** LWW register instantiated using the {{!Irmin_fs_unix} FS backend} provided + by [Irmin_fs_unix] and the timestamp method {!Time.Unix} *) +module FS (V : Irmin.Type.S) : S with type value = V.t + +(** LWW register instantiated using the {{!Irmin_mem} in-memory backend} + provided by [Irmin_mem] and the timestamp method {!Time.Unix} *) +module Mem (V : Irmin.Type.S) : S with type value = V.t diff --git a/vendors/irmin/src/irmin-containers/stores.ml b/vendors/irmin/src/irmin-containers/stores.ml new file mode 100644 index 0000000000000000000000000000000000000000..8474e1724b1648dc342d8b7f49cbf9eb5445b8d3 --- /dev/null +++ b/vendors/irmin/src/irmin-containers/stores.ml @@ -0,0 +1,22 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type Content_addressable = sig + module Make : Irmin.Content_addressable.Maker + + val config : Irmin.config +end diff --git a/vendors/irmin/src/irmin-containers/time.ml b/vendors/irmin/src/irmin-containers/time.ml new file mode 100644 index 0000000000000000000000000000000000000000..9a308d85cb3e2119efd855fd1c873f84fbd63441 --- /dev/null +++ b/vendors/irmin/src/irmin-containers/time.ml @@ -0,0 +1,33 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + include Irmin.Type.S + + val now : unit -> t +end + +module Machine : S = struct + type t = Mtime.t + + let t = + let open Mtime in + Irmin.Type.map ~equal ~compare Irmin.Type.int64 Mtime.of_uint64_ns + Mtime.to_uint64_ns + + let now = Mtime_clock.now +end diff --git a/vendors/irmin/src/irmin-containers/time.mli b/vendors/irmin/src/irmin-containers/time.mli new file mode 100644 index 0000000000000000000000000000000000000000..7a7da4a707d3b779fe2f1810d062b4eafe0ac3de --- /dev/null +++ b/vendors/irmin/src/irmin-containers/time.mli @@ -0,0 +1,32 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [Time] specifies a source of timestamps. Timestamps must be monotonic for + the data structures to function properly. *) + +(** Signature for the timestamps *) +module type S = sig + include Irmin.Type.S + (** Type of the timestamp *) + + val now : unit -> t + (** Returns a timestamp *) +end + +module Machine : S +(** A timestamp method using system-specific monotonic clocks (as provided by + the [Mtime] package). *) diff --git a/vendors/irmin/src/irmin-fs/dune b/vendors/irmin/src/irmin-fs/dune new file mode 100644 index 0000000000000000000000000000000000000000..abe176afd4118c02176770331fccfa36fa9697cb --- /dev/null +++ b/vendors/irmin/src/irmin-fs/dune @@ -0,0 +1,8 @@ +(library + (name irmin_fs) + (public_name irmin-fs) + (libraries astring irmin logs lwt) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-fs/import.ml b/vendors/irmin/src/irmin-fs/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..71053e21ba54118af9da1fc7b37d45eb620c46e2 --- /dev/null +++ b/vendors/irmin/src/irmin-fs/import.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/src/irmin-fs/irmin_fs.ml b/vendors/irmin/src/irmin-fs/irmin_fs.ml new file mode 100644 index 0000000000000000000000000000000000000000..b3d989ea17d1a4c48c6af55a88d9057f6283cbc5 --- /dev/null +++ b/vendors/irmin/src/irmin-fs/irmin_fs.ml @@ -0,0 +1,424 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Astring + +let src = Logs.Src.create "irmin.fs" ~doc:"Irmin disk persistence" + +module Log = (val Logs.src_log src : Logs.LOG) + +let ( / ) = Filename.concat + +module type Config = sig + val dir : string -> string + val file_of_key : string -> string + val key_of_file : string -> string +end + +module type IO = sig + type path = string + + val rec_files : path -> string list Lwt.t + val file_exists : path -> bool Lwt.t + val read_file : path -> string option Lwt.t + val mkdir : path -> unit Lwt.t + + type lock + + val lock_file : string -> lock + val write_file : ?temp_dir:path -> ?lock:lock -> path -> string -> unit Lwt.t + + val test_and_set_file : + ?temp_dir:path -> + lock:lock -> + string -> + test:string option -> + set:string option -> + bool Lwt.t + + val remove_file : ?lock:lock -> path -> unit Lwt.t +end + +(* ~path *) + +module Conf = struct + include Irmin.Backend.Conf + + let spec = Spec.v "ifs" + + module Key = struct + let root = root spec + end +end + +let config r = Conf.(verify (add (empty Conf.spec) Key.root r)) + +module Read_only_ext + (IO : IO) + (S : Config) + (K : Irmin.Type.S) + (V : Irmin.Type.S) = +struct + type key = K.t + type value = V.t + type 'a t = { path : string } + + let get_path config = Option.value Conf.(find_root config) ~default:"." + + let v config = + let path = get_path config in + IO.mkdir path >|= fun () -> { path } + + let close _ = Lwt.return_unit + let cast t = (t :> read_write t) + let batch t f = f (cast t) + + let file_of_key { path; _ } key = + path / S.file_of_key (Irmin.Type.to_string K.t key) + + let lock_of_key { path; _ } key = + IO.lock_file (path / "lock" / S.file_of_key (Irmin.Type.to_string K.t key)) + + let mem t key = + let file = file_of_key t key in + IO.file_exists file + + let of_bin_string = Irmin.Type.(unstage (of_bin_string V.t)) + + let value v = + match of_bin_string v with + | Ok v -> Some v + | Error (`Msg e) -> + [%log.err "Irmin_fs.value %s" e]; + None + + let pp_key = Irmin.Type.pp K.t + + let find t key = + [%log.debug "find %a" pp_key key]; + IO.read_file (file_of_key t key) >|= function + | None -> None + | Some x -> value x + + let list t = + [%log.debug "list"]; + let+ files = IO.rec_files (S.dir t.path) in + let files = + let p = String.length t.path in + List.fold_left + (fun acc file -> + let n = String.length file in + if n <= p + 1 then acc + else + let file = String.with_range file ~first:(p + 1) in + file :: acc) + [] files + in + List.fold_left + (fun acc file -> + match Irmin.Type.of_string K.t (S.key_of_file file) with + | Ok k -> k :: acc + | Error (`Msg e) -> + [%log.err "Irmin_fs.list: %s" e]; + acc) + [] files +end + +module Append_only_ext + (IO : IO) + (S : Config) + (K : Irmin.Type.S) + (V : Irmin.Type.S) = +struct + include Read_only_ext (IO) (S) (K) (V) + + let temp_dir t = t.path / "tmp" + let to_bin_string = Irmin.Type.(unstage (to_bin_string V.t)) + + let add t key value = + [%log.debug "add %a" pp_key key]; + let file = file_of_key t key in + let temp_dir = temp_dir t in + IO.file_exists file >>= function + | true -> Lwt.return_unit + | false -> + let str = to_bin_string value in + IO.write_file ~temp_dir file str +end + +module Atomic_write_ext + (IO : IO) + (S : Config) + (K : Irmin.Type.S) + (V : Irmin.Type.S) = +struct + module RO = Read_only_ext (IO) (S) (K) (V) + module W = Irmin.Backend.Watch.Make (K) (V) + + type t = { t : unit RO.t; w : W.t } + type key = RO.key + type value = RO.value + type watch = W.watch * (unit -> unit Lwt.t) + + let temp_dir t = t.t.RO.path / "tmp" + + module E = Ephemeron.K1.Make (struct + type t = string + + let equal x y = compare x y = 0 + let hash = Hashtbl.hash + end) + + let watches = E.create 10 + + let v config = + let+ t = RO.v config in + let w = + let path = RO.get_path config in + try E.find watches path + with Not_found -> + let w = W.v () in + E.add watches path w; + w + in + { t; w } + + let close t = W.clear t.w >>= fun () -> RO.close t.t + let find t = RO.find t.t + let mem t = RO.mem t.t + let list t = RO.list t.t + + let listen_dir t = + let dir = S.dir t.t.RO.path in + let key file = + match Irmin.Type.of_string K.t file with + | Ok t -> Some t + | Error (`Msg e) -> + [%log.err "listen_dir: %s" e]; + None + in + W.listen_dir t.w dir ~key ~value:(RO.find t.t) + + let watch_key t key ?init f = + let* stop = listen_dir t in + let+ w = W.watch_key t.w key ?init f in + (w, stop) + + let watch t ?init f = + let* stop = listen_dir t in + let+ w = W.watch t.w ?init f in + (w, stop) + + let unwatch t (id, stop) = stop () >>= fun () -> W.unwatch t.w id + let raw_value = Irmin.Type.(unstage (to_bin_string V.t)) + + let set t key value = + [%log.debug "update %a" RO.pp_key key]; + let temp_dir = temp_dir t in + let file = RO.file_of_key t.t key in + let lock = RO.lock_of_key t.t key in + IO.write_file ~temp_dir file ~lock (raw_value value) >>= fun () -> + W.notify t.w key (Some value) + + let remove t key = + [%log.debug "remove %a" RO.pp_key key]; + let file = RO.file_of_key t.t key in + let lock = RO.lock_of_key t.t key in + let* () = IO.remove_file ~lock file in + W.notify t.w key None + + let test_and_set t key ~test ~set = + [%log.debug "test_and_set %a" RO.pp_key key]; + let temp_dir = temp_dir t in + let file = RO.file_of_key t.t key in + let lock = RO.lock_of_key t.t key in + let raw_value = function None -> None | Some v -> Some (raw_value v) in + let* b = + IO.test_and_set_file file ~temp_dir ~lock ~test:(raw_value test) + ~set:(raw_value set) + in + let+ () = if b then W.notify t.w key set else Lwt.return_unit in + b + + let clear t = + [%log.debug "clear"]; + let remove_file key = + IO.remove_file ~lock:(RO.lock_of_key t.t key) (RO.file_of_key t.t key) + in + list t >>= Lwt_list.iter_p remove_file +end + +module Maker_ext (IO : IO) (Obj : Config) (Ref : Config) = struct + module AO = Append_only_ext (IO) (Obj) + module AW = Atomic_write_ext (IO) (Ref) + module CA = Irmin.Content_addressable.Make (AO) + include Irmin.Maker (CA) (AW) +end + +let string_chop_prefix ~prefix str = + let len = String.length prefix in + if String.length str <= len then "" else String.with_range str ~first:len + +module Ref = struct + let dir p = p / "refs" + + (* separator for branch names is '/', so need to rewrite the path on + Windows. *) + + let file_of_key key = + let file = + if Sys.os_type <> "Win32" then key + else String.concat ~sep:Filename.dir_sep (String.cuts ~sep:"/" key) + in + "refs" / file + + let key_of_file file = + let key = string_chop_prefix ~prefix:("refs" / "") file in + if Sys.os_type <> "Win32" then key + else String.concat ~sep:"/" (String.cuts ~sep:Filename.dir_sep key) +end + +module Obj = struct + let dir t = t / "objects" + + let file_of_key k = + let pre = String.with_range k ~len:2 in + let suf = String.with_range k ~first:2 in + "objects" / pre / suf + + let key_of_file path = + let path = string_chop_prefix ~prefix:("objects" / "") path in + let path = String.cuts ~sep:Filename.dir_sep path in + let path = String.concat ~sep:"" path in + path +end + +module Append_only (IO : IO) = Append_only_ext (IO) (Obj) +module Atomic_write (IO : IO) = Atomic_write_ext (IO) (Ref) +module Maker (IO : IO) = Maker_ext (IO) (Obj) (Ref) + +module KV (IO : IO) = struct + module AO = Append_only (IO) + module AW = Atomic_write (IO) + module CA = Irmin.Content_addressable.Make (AO) + include Irmin.KV_maker (CA) (AW) +end + +module IO_mem = struct + type t = { + watches : (string, string -> unit Lwt.t) Hashtbl.t; + files : (string, string) Hashtbl.t; + } + + let t = { watches = Hashtbl.create 3; files = Hashtbl.create 13 } + + type path = string + type lock = Lwt_mutex.t + + let locks = Hashtbl.create 10 + + let lock_file file = + try Hashtbl.find locks file + with Not_found -> + let l = Lwt_mutex.create () in + Hashtbl.add locks file l; + l + + let with_lock l f = + match l with None -> f () | Some l -> Lwt_mutex.with_lock l f + + let set_listen_hook () = + let h _ dir f = + Hashtbl.replace t.watches dir f; + Lwt.return (fun () -> + Hashtbl.remove t.watches dir; + Lwt.return_unit) + in + Irmin.Backend.Watch.set_listen_dir_hook h + + let notify file = + Hashtbl.fold + (fun dir f acc -> + if String.is_prefix ~affix:dir file then f file :: acc else acc) + t.watches [] + |> Lwt_list.iter_p (fun x -> x) + + let mkdir _ = Lwt.return_unit + + let remove_file ?lock file = + with_lock lock (fun () -> + Hashtbl.remove t.files file; + Lwt.return_unit) + + let rec_files dir = + Hashtbl.fold + (fun k _ acc -> if String.is_prefix ~affix:dir k then k :: acc else acc) + t.files [] + |> Lwt.return + + let file_exists file = Hashtbl.mem t.files file |> Lwt.return + + let read_file file = + try + let buf = Hashtbl.find t.files file in + Lwt.return_some buf + with Not_found -> Lwt.return_none + + let write_file ?temp_dir:_ ?lock file v = + let* () = + with_lock lock (fun () -> + Hashtbl.replace t.files file v; + Lwt.return_unit) + in + notify file + + let equal x y = + match (x, y) with + | None, None -> true + | Some x, Some y -> String.equal x y + | _ -> false + + let test_and_set_file ?temp_dir:_ ~lock file ~test ~set = + let f () = + let old = try Some (Hashtbl.find t.files file) with Not_found -> None in + let b = + if not (equal old test) then false + else + match set with + | None -> + Hashtbl.remove t.files file; + true + | Some v -> + Hashtbl.replace t.files file v; + true + in + let+ () = if b then notify file else Lwt.return_unit in + b + in + with_lock (Some lock) f + + let clear () = + Hashtbl.clear t.files; + Hashtbl.clear t.watches; + Lwt.return_unit +end + +(* Enforce that {!S} is a sub-type of {!Irmin.Maker}. *) +module Maker_is_a_maker : Irmin.Maker = Maker (IO_mem) + +(* Enforce that {!KV} is a sub-type of {!Irmin.KV_maker}. *) +module KV_is_a_KV : Irmin.KV_maker = KV (IO_mem) diff --git a/vendors/irmin/src/irmin-fs/irmin_fs.mli b/vendors/irmin/src/irmin-fs/irmin_fs.mli new file mode 100644 index 0000000000000000000000000000000000000000..601cd07cd11a5fb5af7277835498e79da46c1dc6 --- /dev/null +++ b/vendors/irmin/src/irmin-fs/irmin_fs.mli @@ -0,0 +1,109 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Disk persistence. *) + +module Conf : sig + open Irmin.Backend.Conf + + val spec : Spec.t + + module Key : sig + val root : string key + end +end + +val config : string -> Irmin.config +(** [config root] is the a configuration with the key {!Irmin.Config.root} set + to [root]. **) + +module type IO = sig + (** {1 File-system abstractions} *) + + type path = string + (** The type for paths. *) + + (** {2 Read operations} *) + + val rec_files : path -> string list Lwt.t + (** [rec_files dir] is the list of files recursively present in [dir] and all + of its sub-directories. Return filenames prefixed by [dir]. *) + + val file_exists : path -> bool Lwt.t + (** [file_exist f] is true if [f] exists. *) + + val read_file : path -> string option Lwt.t + (** Read the contents of a file using mmap. *) + + (** {2 Write Operations} *) + + val mkdir : path -> unit Lwt.t + (** Create a directory. *) + + type lock + (** The type for file locks. *) + + val lock_file : path -> lock + (** [lock_file f] is the lock associated to the file [f]. *) + + val write_file : ?temp_dir:path -> ?lock:lock -> path -> string -> unit Lwt.t + (** Atomic writes. *) + + val test_and_set_file : + ?temp_dir:string -> + lock:lock -> + path -> + test:string option -> + set:string option -> + bool Lwt.t + (** Test and set. *) + + val remove_file : ?lock:lock -> path -> unit Lwt.t + (** Remove a file or directory (even if non-empty). *) +end + +module Append_only (IO : IO) : Irmin.Append_only.Maker +module Atomic_write (IO : IO) : Irmin.Atomic_write.Maker +module Maker (IO : IO) : Irmin.Maker +module KV (IO : IO) : Irmin.KV_maker + +(** {2 Advanced configuration} *) + +module type Config = sig + (** Same as [Config] but gives more control on the file hierarchy. *) + + val dir : string -> string + (** [dir root] is the sub-directory to look for the keys. *) + + val file_of_key : string -> string + (** Convert a key to a filename. *) + + val key_of_file : string -> string + (** Convert a filename to a key. *) +end + +module Append_only_ext (IO : IO) (C : Config) : Irmin.Append_only.Maker +module Atomic_write_ext (IO : IO) (C : Config) : Irmin.Atomic_write.Maker +module Maker_ext (IO : IO) (Obj : Config) (Ref : Config) : Irmin.Maker + +(** {1 In-memory IO mocks} *) + +module IO_mem : sig + include IO + + val clear : unit -> unit Lwt.t + val set_listen_hook : unit -> unit +end diff --git a/vendors/irmin/src/irmin-fs/unix/dune b/vendors/irmin/src/irmin-fs/unix/dune new file mode 100644 index 0000000000000000000000000000000000000000..e406d43ff9df9871c0bea2bdfde777356337cfa4 --- /dev/null +++ b/vendors/irmin/src/irmin-fs/unix/dune @@ -0,0 +1,8 @@ +(library + (public_name irmin-fs.unix) + (name irmin_fs_unix) + (libraries irmin-fs irmin.unix lwt.unix) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-fs/unix/irmin_fs_unix.ml b/vendors/irmin/src/irmin-fs/unix/irmin_fs_unix.ml new file mode 100644 index 0000000000000000000000000000000000000000..4b11a1cb77e463c57167be8ccc9b010bd345e688 --- /dev/null +++ b/vendors/irmin/src/irmin-fs/unix/irmin_fs_unix.ml @@ -0,0 +1,311 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends + +let src = Logs.Src.create "fs.unix" ~doc:"logs fs unix events" + +module Log = (val Logs.src_log src : Logs.LOG) + +module IO = struct + let mkdir_pool = Lwt_pool.create 1 (fun () -> Lwt.return_unit) + let mmap_threshold = 4096 + + (* Files smaller than this are loaded using [read]. Use of mmap is + necessary to handle packfiles efficiently. Since these are stored + in a weak map, we won't run out of open files if we keep + accessing the same one. Using read is necessary to handle + references, since these are mutable and can't be cached. Using + mmap here leads to hitting the OS limit on the number of open + files. This threshold must be larger than the size of a + reference. *) + + (* Pool of opened files *) + let openfile_pool = Lwt_pool.create 200 (fun () -> Lwt.return_unit) + + let protect_unix_exn = function + | Unix.Unix_error _ as e -> Lwt.fail (Failure (Printexc.to_string e)) + | e -> Lwt.fail e + + let ignore_enoent = function + | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_unit + | e -> Lwt.fail e + + let protect f x = Lwt.catch (fun () -> f x) protect_unix_exn + let safe f x = Lwt.catch (fun () -> f x) ignore_enoent + + let mkdir dirname = + let rec aux dir = + if Sys.file_exists dir && Sys.is_directory dir then Lwt.return_unit + else + let clear = + if Sys.file_exists dir then ( + [%log.debug "%s already exists but is a file, removing." dir]; + safe Lwt_unix.unlink dir) + else Lwt.return_unit + in + clear >>= fun () -> + aux (Filename.dirname dir) >>= fun () -> + [%log.debug "mkdir %s" dir]; + protect (Lwt_unix.mkdir dir) 0o755 + in + Lwt_pool.use mkdir_pool (fun () -> aux dirname) + + let file_exists f = + Lwt.catch + (fun () -> Lwt_unix.file_exists f) + (function + (* See https://github.com/ocsigen/lwt/issues/316 *) + | Unix.Unix_error (Unix.ENOTDIR, _, _) -> Lwt.return_false + | e -> Lwt.fail e) + + module Lock = struct + let is_stale max_age file = + Lwt.catch + (fun () -> + let+ s = Lwt_unix.stat file in + if s.Unix.st_mtime < 1.0 (* ??? *) then false + else Unix.gettimeofday () -. s.Unix.st_mtime > max_age) + (function + | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_false + | e -> Lwt.fail e) + + let unlock file = Lwt_unix.unlink file + + let lock ?(max_age = 10. *. 60. (* 10 minutes *)) ?(sleep = 0.001) file = + let rec aux i = + [%log.debug "lock %s %d" file i]; + let* is_stale = is_stale max_age file in + if is_stale then ( + [%log.err "%s is stale, removing it." file]; + unlock file >>= fun () -> aux 1) + else + let create () = + let pid = Unix.getpid () in + mkdir (Filename.dirname file) >>= fun () -> + let* fd = + Lwt_unix.openfile file + [ Unix.O_CREAT; Unix.O_RDWR; Unix.O_EXCL ] + 0o600 + in + let oc = Lwt_io.of_fd ~mode:Lwt_io.Output fd in + Lwt_io.write_int oc pid >>= fun () -> Lwt_unix.close fd + in + Lwt.catch create (function + | Unix.Unix_error (Unix.EEXIST, _, _) -> + let backoff = + 1. + +. Random.float + (let i = float i in + i *. i) + in + Lwt_unix.sleep (sleep *. backoff) >>= fun () -> aux (i + 1) + | e -> Lwt.fail e) + in + aux 1 + + let with_lock file fn = + match file with + | None -> fn () + | Some f -> lock f >>= fun () -> Lwt.finalize fn (fun () -> unlock f) + end + + type path = string + + (* we use file locking *) + type lock = path + + let lock_file x = x + let file_exists = file_exists + + let list_files kind dir = + if Sys.file_exists dir && Sys.is_directory dir then + let d = Sys.readdir dir in + let d = Array.to_list d in + let d = List.map (Filename.concat dir) d in + let d = List.filter kind d in + let d = List.sort String.compare d in + Lwt.return d + else Lwt.return_nil + + let directories dir = + list_files (fun f -> try Sys.is_directory f with Sys_error _ -> false) dir + + let files dir = + list_files + (fun f -> try not (Sys.is_directory f) with Sys_error _ -> false) + dir + + let write_string fd b = + let rec rwrite fd buf ofs len = + let* n = Lwt_unix.write_string fd buf ofs len in + if len = 0 then Lwt.fail End_of_file + else if n < len then rwrite fd buf (ofs + n) (len - n) + else Lwt.return_unit + in + match String.length b with 0 -> Lwt.return_unit | len -> rwrite fd b 0 len + + let delays = Array.init 20 (fun i -> 0.1 *. (float i ** 2.)) + + let command fmt = + Printf.ksprintf + (fun str -> + [%log.debug "[exec] %s" str]; + let i = Sys.command str in + if i <> 0 then [%log.debug "[exec] error %d" i]; + Lwt.return_unit) + fmt + + let remove_dir dir = + if Sys.os_type = "Win32" then command "cmd /d /v:off /c rd /s /q %S" dir + else command "rm -rf %S" dir + + let remove_file ?lock file = + Lock.with_lock lock (fun () -> + Lwt.catch + (fun () -> Lwt_unix.unlink file) + (function + (* On Windows, [EACCES] can also occur in an attempt to + rename a file or directory or to remove an existing + directory. *) + | Unix.Unix_error (Unix.EACCES, _, _) + | Unix.Unix_error (Unix.EISDIR, _, _) -> + remove_dir file + | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_unit + | e -> Lwt.fail e)) + + let rename = + if Sys.os_type <> "Win32" then Lwt_unix.rename + else fun tmp file -> + let rec aux i = + Lwt.catch + (fun () -> Lwt_unix.rename tmp file) + (function + (* On Windows, [EACCES] can also occur in an attempt to + rename a file or directory or to remove an existing + directory. *) + | Unix.Unix_error (Unix.EACCES, _, _) as e -> + if i >= Array.length delays then Lwt.fail e + else + let* exists = file_exists file in + if exists && Sys.is_directory file then + remove_dir file >>= fun () -> aux (i + 1) + else ( + [%log.debug "Got EACCES, retrying in %.1fs" delays.(i)]; + Lwt_unix.sleep delays.(i) >>= fun () -> aux (i + 1)) + | e -> Lwt.fail e) + in + aux 0 + + let with_write_file ?temp_dir file fn = + let* () = + match temp_dir with None -> Lwt.return_unit | Some d -> mkdir d + in + let dir = Filename.dirname file in + mkdir dir >>= fun () -> + let tmp = Filename.temp_file ?temp_dir (Filename.basename file) "write" in + Lwt_pool.use openfile_pool (fun () -> + [%log.debug "Writing %s (%s)" file tmp]; + let* fd = + let open Lwt_unix in + openfile tmp [ O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC ] 0o644 + in + let* () = + Lwt.finalize (fun () -> protect fn fd) (fun () -> Lwt_unix.close fd) + in + rename tmp file) + + let read_file_with_read file size = + let chunk_size = max 4096 (min size 0x100000) in + let buf = Bytes.create size in + let flags = [ Unix.O_RDONLY ] in + let perm = 0o0 in + let* fd = Lwt_unix.openfile file flags perm in + let rec aux off = + let read_size = min chunk_size (size - off) in + let* read = Lwt_unix.read fd buf off read_size in + let off = off + read in + if off >= size then Lwt.return (Bytes.unsafe_to_string buf) else aux off + in + Lwt.finalize (fun () -> aux 0) (fun () -> Lwt_unix.close fd) + + let read_file_with_mmap file = + let fd = Unix.(openfile file [ O_RDONLY; O_NONBLOCK ] 0o644) in + let ba = Lwt_bytes.map_file ~fd ~shared:false () in + Unix.close fd; + + (* XXX(samoht): ideally we should not do a copy here. *) + Lwt.return (Lwt_bytes.to_string ba) + + let read_file file = + Lwt.catch + (fun () -> + Lwt_pool.use openfile_pool (fun () -> + [%log.debug "Reading %s" file]; + let* stats = Lwt_unix.stat file in + let size = stats.Lwt_unix.st_size in + let+ buf = + if size >= mmap_threshold then read_file_with_mmap file + else read_file_with_read file size + in + Some buf)) + (function + | Unix.Unix_error _ | Sys_error _ -> Lwt.return_none | e -> Lwt.fail e) + + let write_file ?temp_dir ?lock file b = + let write () = + with_write_file file ?temp_dir (fun fd -> write_string fd b) + in + Lock.with_lock lock (fun () -> + Lwt.catch write (function + | Unix.Unix_error (Unix.EISDIR, _, _) -> remove_dir file >>= write + | e -> Lwt.fail e)) + + let test_and_set_file ?temp_dir ~lock file ~test ~set = + Lock.with_lock (Some lock) (fun () -> + let* v = read_file file in + let equal = + match (test, v) with + | None, None -> true + | Some x, Some y -> String.equal x y + | _ -> false + in + if not equal then Lwt.return_false + else + let+ () = + match set with + | None -> remove_file file + | Some v -> write_file ?temp_dir file v + in + true) + + let rec_files dir = + let rec aux accu dir = + let* ds = directories dir in + let* fs = files dir in + Lwt_list.fold_left_s aux (fs @ accu) ds + in + aux [] dir +end + +module Append_only = Irmin_fs.Append_only (IO) +module Atomic_write = Irmin_fs.Atomic_write (IO) +include Irmin_fs.Maker (IO) +module KV = Irmin_fs.KV (IO) +module Append_only_ext = Irmin_fs.Append_only_ext (IO) +module Atomic_write_ext = Irmin_fs.Atomic_write_ext (IO) +module Maker_ext = Irmin_fs.Maker_ext (IO) +include Irmin_unix diff --git a/vendors/irmin/src/irmin-fs/unix/irmin_fs_unix.mli b/vendors/irmin/src/irmin-fs/unix/irmin_fs_unix.mli new file mode 100644 index 0000000000000000000000000000000000000000..e754c43574848511b1aa18d46fb5fc04e8350ba0 --- /dev/null +++ b/vendors/irmin/src/irmin-fs/unix/irmin_fs_unix.mli @@ -0,0 +1,30 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Append_only : Irmin.Append_only.Maker +module Atomic_write : Irmin.Atomic_write.Maker +include Irmin.Maker +module KV : Irmin.KV_maker + +(** {1 Extended Stores} *) + +module Append_only_ext (C : Irmin_fs.Config) : Irmin.Append_only.Maker +module Atomic_write_ext (C : Irmin_fs.Config) : Irmin.Atomic_write.Maker +module Maker_ext (Obj : Irmin_fs.Config) (Ref : Irmin_fs.Config) : Irmin.Maker + +(** {1 Common Unix utilities} *) + +include module type of Irmin_unix diff --git a/vendors/irmin/src/irmin-git/atomic_write.ml b/vendors/irmin/src/irmin-git/atomic_write.ml new file mode 100644 index 0000000000000000000000000000000000000000..58ea59963f89b380fc6eced895a674be16561be6 --- /dev/null +++ b/vendors/irmin/src/irmin-git/atomic_write.ml @@ -0,0 +1,308 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +include Atomic_write_intf + +module Check_closed (S : Irmin.Atomic_write.S) = struct + type t = { closed : bool ref; t : S.t } + type key = S.key + type value = S.value + + let check_not_closed t = if !(t.closed) then raise Irmin.Closed + + let mem t k = + check_not_closed t; + S.mem t.t k + + let find t k = + check_not_closed t; + S.find t.t k + + let set t k v = + check_not_closed t; + S.set t.t k v + + let test_and_set t k ~test ~set = + check_not_closed t; + S.test_and_set t.t k ~test ~set + + let remove t k = + check_not_closed t; + S.remove t.t k + + let list t = + check_not_closed t; + S.list t.t + + type watch = S.watch + + let watch t ?init f = + check_not_closed t; + S.watch t.t ?init f + + let watch_key t k ?init f = + check_not_closed t; + S.watch_key t.t k ?init f + + let unwatch t w = + check_not_closed t; + S.unwatch t.t w + + let v t = { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) + + let clear t = + check_not_closed t; + S.clear t.t +end + +module Make (K : Key) (G : Git.S) = struct + module Key = K + module Val = Irmin.Hash.Make (G.Hash) + module W = Irmin.Backend.Watch.Make (Key) (Val) + + let handle_git_err = function + | Ok x -> Lwt.return x + | Error e -> Fmt.kstr Lwt.fail_with "%a" G.pp_error e + + type t = { + bare : bool; + dot_git : Fpath.t; + git_head : G.Hash.t Git.Reference.contents; + t : G.t; + w : W.t; + m : Lwt_mutex.t; + } + + let watches = Hashtbl.create 10 + + type key = Key.t + type value = Val.t + type watch = W.watch * (unit -> unit Lwt.t) + + let branch_of_git r = + let str = String.trim @@ Git.Reference.to_string r in + match K.of_ref str with Ok r -> Some r | Error (`Msg _) -> None + + let git_of_branch r = Git.Reference.v (Fmt.to_to_string K.pp_ref r) + let pp_key = Irmin.Type.pp Key.t + + let ref_read_opt t head = + (* Make a best-effort attempt to check that the reference actually + exists before [read]-ing it, since the [Error `Reference_not_found] + case causes a spurious warning to be logged inside [ocaml-git]. *) + G.Ref.mem t head >>= function + | false -> Lwt.return_none + | true -> ( + let* r = G.Ref.read t head in + match r with + | Ok r -> Lwt.return_some r + | Error (`Reference_not_found _ | `Not_found _) -> + (* We may still hit this case due to a race condition, but it's very unlikely. *) + Lwt.return_none + | Error e -> Fmt.kstr Lwt.fail_with "%a" G.pp_error e) + + let mem { t; _ } r = + [%log.debug "mem %a" pp_key r]; + G.Ref.mem t (git_of_branch r) + + let find { t; _ } r = + [%log.debug "find %a" pp_key r]; + let b = git_of_branch r in + let* exists = G.Ref.mem t b in + if not exists then Lwt.return_none + else + let* k = G.Ref.resolve t b in + match k with + | Error (`Reference_not_found _) -> Lwt.return_none + | Error e -> Fmt.kstr Lwt.fail_with "%a" G.pp_error e + | Ok k -> Lwt.return_some k + + let listen_dir t = + let ( / ) = Filename.concat in + if G.has_global_watches then + let dir = Fpath.(to_string @@ (t.dot_git / "refs" / "heads")) in + let key file = + match K.of_ref ("refs" / "heads" / file) with + | Ok x -> Some x + | Error (`Msg e) -> + [%log.err "listen: file %s: %s" file e]; + None + in + W.listen_dir t.w dir ~key ~value:(find t) + else Lwt.return (fun () -> Lwt.return_unit) + + let watch_key t key ?init f = + [%log.debug "watch_key %a" pp_key key]; + let* stop = listen_dir t in + let+ w = W.watch_key t.w key ?init f in + (w, stop) + + let watch t ?init f = + [%log.debug "watch"]; + let* stop = listen_dir t in + let+ w = W.watch t.w ?init f in + (w, stop) + + let unwatch t (w, stop) = + let* () = stop () in + W.unwatch t.w w + + let v ?lock ~head ~bare t = + let m = match lock with None -> Lwt_mutex.create () | Some l -> l in + let dot_git = G.dotgit t in + let write_head head = + let head = Git.Reference.Ref head in + let+ () = + let+ r = + if G.has_global_checkout then + Lwt_mutex.with_lock m (fun () -> + G.Ref.write t Git.Reference.head head) + else Lwt.return (Ok ()) + in + match r with + | Error e -> [%log.err "Cannot create HEAD: %a" G.pp_error e] + | Ok () -> () + in + head + in + let+ git_head = + match head with + | Some h -> write_head h + | None -> ( + ref_read_opt t Git.Reference.head >>= function + | None -> write_head (git_of_branch K.main) + | Some head -> Lwt.return head) + in + let w = + try Hashtbl.find watches (G.dotgit t) + with Not_found -> + let w = W.v () in + Hashtbl.add watches (G.dotgit t) w; + w + in + { git_head; bare; t; w; dot_git; m } + + let list { t; _ } = + [%log.debug "list"]; + let+ refs = G.Ref.list t in + List.fold_left + (fun acc (r, _) -> + match branch_of_git r with None -> acc | Some r -> r :: acc) + [] refs + + let write_index t gr gk = + [%log.debug "write_index"]; + if G.has_global_checkout then [%log.debug "write_index"]; + let git_head = Git.Reference.Ref gr in + [%log.debug "write_index/if bare=%b head=%a" t.bare Git.Reference.pp gr]; + if (not t.bare) && git_head = t.git_head then ( + [%log.debug "write cache (%a)" Git.Reference.pp gr]; + + (* FIXME G.write_index t.t gk *) + let _ = gk in + Lwt.return_unit) + else Lwt.return_unit + + let pp_branch = Irmin.Type.pp K.t + + let set t r k = + [%log.debug "set %a" pp_branch r]; + let gr = git_of_branch r in + Lwt_mutex.with_lock t.m @@ fun () -> + let* e = G.Ref.write t.t gr (Git.Reference.Uid k) in + let* () = handle_git_err e in + let* () = W.notify t.w r (Some k) in + write_index t gr k + + let remove t r = + [%log.debug "remove %a" pp_branch r]; + Lwt_mutex.with_lock t.m @@ fun () -> + let* e = G.Ref.remove t.t (git_of_branch r) in + let* () = handle_git_err e in + W.notify t.w r None + + let eq_head_contents_opt x y = + match (x, y) with + | None, None -> true + | Some x, Some y -> Git.Reference.equal_contents ~equal:G.Hash.equal x y + | _ -> false + + let test_and_set t r ~test ~set = + [%log.debug fun f -> + let pp = Fmt.option ~none:(Fmt.any "") (Irmin.Type.pp Val.t) in + f "test_and_set %a: %a => %a" pp_branch r pp test pp set] + ; + let gr = git_of_branch r in + let c = function None -> None | Some h -> Some (Git.Reference.Uid h) in + let ok r = + let+ () = handle_git_err r in + true + in + Lwt_mutex.with_lock t.m (fun () -> + let* x = ref_read_opt t.t gr in + let* b = + if not (eq_head_contents_opt x (c test)) then Lwt.return_false + else + match c set with + | None -> + let* r = G.Ref.remove t.t gr in + ok r + | Some h -> + let* r = G.Ref.write t.t gr h in + ok r + in + let* () = + if + (* We do not protect [write_index] because it can take a long + time and we don't want to hold the lock for too long. Would + be safer to grab a lock, although the expanded filesystem + is not critical for Irmin consistency (it's only a + convenience for the user). *) + b + then W.notify t.w r set + else Lwt.return_unit + in + let+ () = + if b then + match set with + | None -> Lwt.return_unit + | Some v -> write_index t gr v + else Lwt.return_unit + in + b) + + let close _ = Lwt.return_unit + + let clear t = + [%log.debug "clear"]; + Lwt_mutex.with_lock t.m (fun () -> + let* refs = G.Ref.list t.t in + Lwt_list.iter_p + (fun (r, _) -> + let* e = G.Ref.remove t.t r in + let* () = handle_git_err e in + match branch_of_git r with + | Some k -> W.notify t.w k None + | None -> Lwt.return_unit) + refs) +end diff --git a/vendors/irmin/src/irmin-git/atomic_write.mli b/vendors/irmin/src/irmin-git/atomic_write.mli new file mode 100644 index 0000000000000000000000000000000000000000..419e1da5af59ab27d554f7b387f6d22f0233c0f8 --- /dev/null +++ b/vendors/irmin/src/irmin-git/atomic_write.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Backend module: turn a Git store into an Irmin backend for Git references. *) + +include Atomic_write_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-git/atomic_write_intf.ml b/vendors/irmin/src/irmin-git/atomic_write_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..92f5b2731f56940bede7718c806f716ba6a964a0 --- /dev/null +++ b/vendors/irmin/src/irmin-git/atomic_write_intf.ml @@ -0,0 +1,43 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type Key = sig + include Irmin.Branch.S + + val pp_ref : t Fmt.t + val of_ref : string -> (t, [ `Msg of string ]) result +end + +module type Sigs = sig + module type Key = Key + + module Make (K : Key) (G : Git.S) : sig + include Irmin.Atomic_write.S with type key = K.t and type value = G.Hash.t + + val v : + ?lock:Lwt_mutex.t -> + head:G.Reference.t option -> + bare:bool -> + G.t -> + t Lwt.t + end + + module Check_closed (S : Irmin.Atomic_write.S) : sig + include Irmin.Atomic_write.S with type key = S.key and type value = S.value + + val v : S.t -> t + end +end diff --git a/vendors/irmin/src/irmin-git/backend.ml b/vendors/irmin/src/irmin-git/backend.ml new file mode 100644 index 0000000000000000000000000000000000000000..7acccf408a079ec91999468a2e17b97e9f011aad --- /dev/null +++ b/vendors/irmin/src/irmin-git/backend.ml @@ -0,0 +1,133 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +module type G = sig + include Git.S + + val v : ?dotgit:Fpath.t -> Fpath.t -> (t, error) result Lwt.t +end + +module Make + (G : G) + (S : Git.Sync.S with type hash := G.hash and type store := G.t) + (Schema : Schema.S + with type Hash.t = G.hash + and type Node.t = G.Value.Tree.t + and type Commit.t = G.Value.Commit.t) = +struct + module Hash = Irmin.Hash.Make (G.Hash) + module Schema = Schema + module Key = Irmin.Key.Of_hash (Hash) + module Commit_key = Key + module Node_key = Key + + module Contents = struct + module S = Contents.Make (G) (Schema.Contents) + include Irmin.Contents.Store (S) (S.Hash) (S.Val) + end + + module Node = struct + module S = Node.Store (G) (Schema.Path) + + include + Irmin.Node.Store (Contents) (S) (S.Key) (S.Val) (Metadata) (Schema.Path) + end + + module Node_portable = Irmin.Node.Portable.Of_node (Node.Val) + + module Commit = struct + module S = Commit.Store (G) + include Irmin.Commit.Store (Schema.Info) (Node) (S) (S.Hash) (S.Val) + end + + module Commit_portable = Irmin.Commit.Portable.Of_commit (Commit.S.Val) + + module Branch = struct + module Key = Schema.Branch + module Val = Commit_key + module S = Atomic_write.Make (Schema.Branch) (G) + include Atomic_write.Check_closed (S) + + let v ?lock ~head ~bare t = S.v ?lock ~head ~bare t >|= v + end + + module Slice = Irmin.Backend.Slice.Make (Contents) (Node) (Commit) + + module Repo = struct + let handle_git_err = function + | Ok x -> Lwt.return x + | Error e -> Fmt.kstr Lwt.fail_with "%a" G.pp_error e + + type t = { config : Irmin.config; closed : bool ref; g : G.t; b : Branch.t } + + let branch_t t = t.b + let contents_t t : 'a Contents.t = (t.closed, t.g) + let node_t t : 'a Node.t = (contents_t t, (t.closed, t.g)) + let commit_t t : 'a Commit.t = (node_t t, (t.closed, t.g)) + let batch t f = f (contents_t t) (node_t t) (commit_t t) + + type config = { + root : string; + dot_git : string option; + level : int option; + buffers : int option; + head : G.Reference.t option; + bare : bool; + } + + let config c = + let module C = Irmin.Backend.Conf in + let root = C.find_root c |> Option.value ~default:"." in + let dot_git = C.get c Conf.Key.dot_git in + let level = C.get c Conf.Key.level in + let head = C.get c Conf.Key.head in + let bare = C.get c Conf.Key.bare in + let buffers = C.get c Conf.Key.buffers in + { root; dot_git; level; head; buffers; bare } + + let fopt f = function None -> None | Some x -> Some (f x) + + let v conf = + let { root; dot_git; head; bare; _ } = config conf in + let dotgit = fopt Fpath.v dot_git in + let root = Fpath.v root in + let* g = G.v ?dotgit root >>= handle_git_err in + let+ b = Branch.v ~head ~bare g in + { g; b; closed = ref false; config = (conf :> Irmin.config) } + + let config t = t.config + let close t = Branch.close t.b >|= fun () -> t.closed := true + end + + module Remote = struct + include Remote.Make (G) (S) (Schema.Branch) + + let v repo = Lwt.return repo.Repo.g + end + + let git_of_repo r = r.Repo.g + + let repo_of_git ?head ?(bare = true) ?lock g = + let+ b = Branch.v ?lock ~head ~bare g in + { + Repo.config = Irmin.Backend.Conf.empty Conf.spec; + closed = ref false; + g; + b; + } +end diff --git a/vendors/irmin/src/irmin-git/backend.mli b/vendors/irmin/src/irmin-git/backend.mli new file mode 100644 index 0000000000000000000000000000000000000000..fe261ae8a6dddb6531ff325d19bc75e003c65dd2 --- /dev/null +++ b/vendors/irmin/src/irmin-git/backend.mli @@ -0,0 +1,51 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type G = sig + include Git.S + + val v : ?dotgit:Fpath.t -> Fpath.t -> (t, error) result Lwt.t +end + +module Make + (G : G) + (S : Git.Sync.S with type hash := G.hash and type store := G.t) + (Schema : Schema.S + with type Hash.t = G.hash + and type Node.t = G.Value.Tree.t + and type Commit.t = G.Value.Commit.t) : sig + type t := bool ref * G.t + + include + Irmin.Backend.S + with module Schema = Schema + with type 'a Contents.t = t + and type 'a Node.t = t * t + and type 'a Commit.t = (t * t) * t + and type Contents.key = G.hash + and type Node.key = G.hash + and type Commit.key = G.hash + and type Remote.endpoint = Mimic.ctx * Smart_git.Endpoint.t + + val git_of_repo : Repo.t -> G.t + + val repo_of_git : + ?head:Git.Reference.t -> + ?bare:bool -> + ?lock:Lwt_mutex.t -> + G.t -> + Repo.t Lwt.t +end diff --git a/vendors/irmin/src/irmin-git/branch.ml b/vendors/irmin/src/irmin-git/branch.ml new file mode 100644 index 0000000000000000000000000000000000000000..830c7ac90f10a8d8e74dbc85243f7ec52608dcdb --- /dev/null +++ b/vendors/irmin/src/irmin-git/branch.ml @@ -0,0 +1,32 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Astring + +module type S = Atomic_write.Key + +module Make (B : Irmin.Branch.S) = struct + include B + + let pp = Irmin.Type.pp B.t + let pp_ref ppf b = Fmt.pf ppf "refs/heads/%a" pp b + + let of_ref str = + match String.cuts ~sep:"/" str with + | "refs" :: "heads" :: b -> + Irmin.Type.of_string B.t (String.concat ~sep:"/" b) + | _ -> Error (`Msg (Fmt.str "%s is not a valid branch" str)) +end diff --git a/vendors/irmin/src/irmin-git/branch.mli b/vendors/irmin/src/irmin-git/branch.mli new file mode 100644 index 0000000000000000000000000000000000000000..9c8ccfda5855a7418b637df7e0652a7936ebe3d2 --- /dev/null +++ b/vendors/irmin/src/irmin-git/branch.mli @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** one-to-one mapping between Irmin and Git branches. *) + +module type S = sig + include Atomic_write.Key + (** inline *) +end + +module Make (B : Irmin.Branch.S) : S with type t = B.t diff --git a/vendors/irmin/src/irmin-git/commit.ml b/vendors/irmin/src/irmin-git/commit.ml new file mode 100644 index 0000000000000000000000000000000000000000..e35223e02ee5f2bb9f730867217508d94301e31f --- /dev/null +++ b/vendors/irmin/src/irmin-git/commit.ml @@ -0,0 +1,126 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +module Make (G : Git.S) = struct + module Info = Irmin.Info.Default + module Raw = Git.Value.Make (G.Hash) + module Hash = Irmin.Hash.Make (G.Hash) + module Key = Irmin.Key.Of_hash (Hash) + + type t = G.Value.Commit.t + type commit_key = Key.t [@@deriving irmin] + type node_key = Key.t [@@deriving irmin] + type hash = Hash.t [@@deriving irmin] + + let info_of_git author message = + let id = author.Git.User.name in + let date, _ = author.Git.User.date in + (* FIXME: tz offset is ignored *) + Info.v ~author:id ~message date + + let name_email name = + let name = String.trim name in + try + let i = String.rindex name ' ' in + let email = String.sub name (i + 1) (String.length name - i - 1) in + if + String.length email > 0 + && email.[0] = '<' + && email.[String.length email - 1] = '>' + then + let email = String.sub email 1 (String.length email - 2) in + let name = String.trim (String.sub name 0 i) in + (name, email) + else (name, "irmin@openmirage.org") + with Not_found -> (name, "irmin@openmirage.org") + + let of_git g = + let node = G.Value.Commit.tree g in + let parents = G.Value.Commit.parents g in + let author = G.Value.Commit.author g in + let message = G.Value.Commit.message g in + let message = Option.value ~default:"" message in + let info = info_of_git author message in + (info, node, parents) + + let to_git info node parents = + let tree = node in + let parents = List.fast_sort G.Hash.compare parents in + let author = + let date = Info.date info in + let name, email = name_email (Info.author info) in + Git.User.{ name; email; date = (date, None) } + in + let message = Info.message info in + G.Value.Commit.make (* FIXME: should be v *) + ~tree ~parents ~author ~committer:author + (if message = "" then None else Some message) + + let v ~info ~node ~parents = to_git info node parents + let xnode g = G.Value.Commit.tree g + let node t = xnode t + let parents g = G.Value.Commit.parents g + + let info g = + let author = G.Value.Commit.author g in + let message = Option.value ~default:"" (G.Value.Commit.message g) in + info_of_git author message + + module C = Irmin.Commit.Make (Hash) + + let of_c c = to_git (C.info c) (C.node c) (C.parents c) + + let to_c t = + let info, node, parents = of_git t in + C.v ~info ~node ~parents + + let to_bin t = Raw.to_raw (G.Value.commit t) + + let encode_bin (t : t) k = + [%log.debug "Commit.encode_bin"]; + k (to_bin t) + + let decode_bin buf pos_ref = + [%log.debug "Commit.decode_bin"]; + let off = !pos_ref in + match Raw.of_raw_with_header ~off buf with + | Ok (Git.Value.Commit t) -> + pos_ref := String.length buf; + t + | Ok _ -> failwith "wrong object kind" + | Error _ -> failwith "wrong object kind" + + let size_of = Irmin.Type.Size.custom_dynamic () + let t = Irmin.Type.map ~bin:(encode_bin, decode_bin, size_of) C.t of_c to_c +end + +module Store (G : Git.S) = struct + module Info = Irmin.Info.Default + module Hash = Irmin.Hash.Make (G.Hash) + module Val = Make (G) + + module V = struct + type t = G.Value.Commit.t + + let type_eq = function `Commit -> true | _ -> false + let of_git = function Git.Value.Commit c -> Some c | _ -> None + let to_git c = G.Value.commit c + end + + include Content_addressable.Check_closed (Content_addressable.Make (G) (V)) +end diff --git a/vendors/irmin/src/irmin-git/commit.mli b/vendors/irmin/src/irmin-git/commit.mli new file mode 100644 index 0000000000000000000000000000000000000000..506dc5e0618747dde456ce3d2352d78e7e51b07c --- /dev/null +++ b/vendors/irmin/src/irmin-git/commit.mli @@ -0,0 +1,40 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Backend module: turn a Git store into an Irmin backend for Git commits. *) + +module Make (G : Git.S) : + Irmin.Commit.S + with type t = G.Value.Commit.t + and type hash = G.hash + and module Info = Irmin.Info.Default + +module Store (G : Git.S) : sig + include + Irmin.Content_addressable.S + with type _ t = bool ref * G.t + and type key = G.Hash.t + and type value = G.Value.Commit.t + + module Info = Irmin.Info.Default + module Hash : Irmin.Hash.S with type t = key + + module Val : + Irmin.Commit.S + with type t = value + and type hash = key + and module Info = Info +end diff --git a/vendors/irmin/src/irmin-git/conf.ml b/vendors/irmin/src/irmin-git/conf.ml new file mode 100644 index 0000000000000000000000000000000000000000..ad95ba6f0197613aa7cff9ad06d56371555d5a1c --- /dev/null +++ b/vendors/irmin/src/irmin-git/conf.ml @@ -0,0 +1,70 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Backend.Conf + +let spec = Spec.v "git" + +module Key = struct + let reference : Git.Reference.t Irmin.Type.t = + let of_string str = Git.Reference.of_string str |> Result.get_ok in + let to_string r = Git.Reference.to_string r in + Irmin.Type.(map string) of_string to_string + + let head = + key ~spec ~doc:"The main branch of the Git repository." "head" + Irmin.Type.(option reference) + None + + let bare = + key ~spec ~doc:"Do not expand the filesystem on the disk." "bare" + Irmin.Type.bool false + + let level = + key ~spec ~doc:"The Zlib compression level." "level" + Irmin.Type.(option int) + None + + let buffers = + key ~spec ~doc:"The number of 4K pre-allocated buffers." "buffers" + Irmin.Type.(option int) + None + + let dot_git = + key ~spec + ~doc:"The location of the .git directory. By default set to [$root/.git]." + "dot-git" + Irmin.Type.(option string) + None +end + +let init ?head ?bare ?level ?dot_git ?buffers root = + let module C = Irmin.Backend.Conf in + let config = C.empty spec in + (* Initialise an fresh root_key, otherwise [C.add config root_key root] has no + effect on current config. *) + let root_key = C.root spec in + let config = C.add config root_key root in + let config = + match bare with + | None -> C.add config Key.bare (C.default Key.bare) + | Some b -> C.add config Key.bare b + in + let config = C.add config Key.head head in + let config = C.add config Key.level level in + let config = C.add config Key.dot_git dot_git in + let config = C.add config Key.buffers buffers in + C.verify config diff --git a/vendors/irmin/src/irmin-git/conf.mli b/vendors/irmin/src/irmin-git/conf.mli new file mode 100644 index 0000000000000000000000000000000000000000..00672756de402f8d6a938093e7d518d189c9f595 --- /dev/null +++ b/vendors/irmin/src/irmin-git/conf.mli @@ -0,0 +1,36 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Backend.Conf + +val spec : Spec.t + +module Key : sig + val head : Git.Reference.t option key + val bare : bool key + val level : int option key + val buffers : int option key + val dot_git : string option key +end + +val init : + ?head:Git.Reference.t -> + ?bare:bool -> + ?level:int -> + ?dot_git:string -> + ?buffers:int -> + string -> + Irmin.config diff --git a/vendors/irmin/src/irmin-git/content_addressable.ml b/vendors/irmin/src/irmin-git/content_addressable.ml new file mode 100644 index 0000000000000000000000000000000000000000..c0fd2c5128ac7dabf01f9c1c22675fd33790c3a8 --- /dev/null +++ b/vendors/irmin/src/irmin-git/content_addressable.ml @@ -0,0 +1,96 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +include Content_addressable_intf + +module Make (G : Git.S) (V : Value.S with type value := G.Value.t) = struct + module H = Irmin.Hash.Make (G.Hash) + + let handle_git_err = function + | Ok x -> Lwt.return x + | Error e -> Fmt.kstr Lwt.fail_with "%a" G.pp_error e + + type 'a t = G.t + type key = H.t [@@deriving irmin ~pp ~equal] + type value = V.t + + let mem t key = + [%log.debug "mem %a" pp_key key]; + G.mem t key >>= function + | false -> Lwt.return_false + | true -> ( + G.read t key >>= function + | Error (`Reference_not_found _ | `Not_found _) -> Lwt.return_false + | Error e -> Fmt.kstr Lwt.fail_with "%a" G.pp_error e + | Ok v -> Lwt.return (V.type_eq (G.Value.kind v))) + + let find t key = + [%log.debug "find %a" pp_key key]; + G.read t key >>= function + | Error (`Reference_not_found _ | `Not_found _) -> Lwt.return_none + | Error e -> Fmt.kstr Lwt.fail_with "%a" G.pp_error e + | Ok v -> Lwt.return (V.of_git v) + + let add t v = + let v = V.to_git v in + let* k, _ = G.write t v >>= handle_git_err in + [%log.debug "add %a" pp_key k]; + Lwt.return k + + let unsafe_add t k v = + let+ k' = add t v in + if equal_key k k' then () + else + Fmt.failwith + "[Git.unsafe_append] %a is not a valid key. Expecting %a instead.\n" + pp_key k pp_key k' + + let batch t f = f t + let close _ = Lwt.return () +end + +module Check_closed (S : Irmin.Content_addressable.S) = struct + type 'a t = bool ref * 'a S.t + type key = S.key + type value = S.value + + let check_not_closed t = if !(fst t) then raise Irmin.Closed + + let mem t k = + check_not_closed t; + S.mem (snd t) k + + let find t k = + check_not_closed t; + S.find (snd t) k + + let add t v = + check_not_closed t; + S.add (snd t) v + + let unsafe_add t k v = + check_not_closed t; + S.unsafe_add (snd t) k v + + let batch t f = + check_not_closed t; + S.batch (snd t) (fun x -> f (fst t, x)) + + let close (c, _) = + c := true; + Lwt.return () +end diff --git a/vendors/irmin/src/irmin-git/content_addressable.mli b/vendors/irmin/src/irmin-git/content_addressable.mli new file mode 100644 index 0000000000000000000000000000000000000000..5eec2a5c3482b837f4d94345135c4ef0dbeadcf9 --- /dev/null +++ b/vendors/irmin/src/irmin-git/content_addressable.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Backend module: turn a Git store into an Irmin backend for Git values. *) + +include Content_addressable_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-git/content_addressable_intf.ml b/vendors/irmin/src/irmin-git/content_addressable_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..52324bcf4673c14c351433bd5c1ff615bbee5ba7 --- /dev/null +++ b/vendors/irmin/src/irmin-git/content_addressable_intf.ml @@ -0,0 +1,31 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type Sigs = sig + module Make (G : Git.S) (V : Value.S with type value := G.Value.t) : + Irmin.Content_addressable.S + with type _ t = G.t + and type key = G.Hash.t + and type value = V.t + + module Check_closed (S : Irmin.Content_addressable.S) : sig + include + Irmin.Content_addressable.S + with type 'a t = bool ref * 'a S.t + and type key = S.key + and type value = S.value + end +end diff --git a/vendors/irmin/src/irmin-git/contents.ml b/vendors/irmin/src/irmin-git/contents.ml new file mode 100644 index 0000000000000000000000000000000000000000..62c50b5c9f44af5b62c0128a92f8df56bb83d5e5 --- /dev/null +++ b/vendors/irmin/src/irmin-git/contents.ml @@ -0,0 +1,64 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +module Make (G : Git.S) (C : Irmin.Contents.S) = struct + module Raw = Git.Value.Make (G.Hash) + module Hash = Irmin.Hash.Make (G.Hash) + + module V = struct + type t = C.t + + let type_eq = function `Blob -> true | _ -> false + + let of_git = function + | Git.Value.Blob b -> ( + let str = G.Value.Blob.to_string b in + match Irmin.Type.of_string C.t str with + | Ok x -> Some x + | Error (`Msg e) -> Fmt.invalid_arg "error %s" e) + | _ -> None + + let to_git b = + let str = Irmin.Type.to_string C.t b in + G.Value.blob (G.Value.Blob.of_string str) + end + + include Content_addressable.Check_closed (Content_addressable.Make (G) (V)) + + module Val = struct + include C + + let to_bin t = Raw.to_raw (V.to_git t) + let encode_bin (t : t) k = k (to_bin t) + + let decode_bin buf pos_ref = + [%log.debug "Content.decode_bin"]; + let off = !pos_ref in + match Raw.of_raw_with_header ~off buf with + | Ok g -> ( + match V.of_git g with + | Some g -> + pos_ref := String.length buf; + g + | None -> failwith "wrong object kind") + | Error (`Msg _) -> failwith "wrong object" + + let size_of = Irmin.Type.Size.custom_dynamic () + let t = Irmin.Type.like ~bin:(encode_bin, decode_bin, size_of) t + end +end diff --git a/vendors/irmin/src/irmin-git/contents.mli b/vendors/irmin/src/irmin-git/contents.mli new file mode 100644 index 0000000000000000000000000000000000000000..d4a06b35cc58bcab7d5fcfab7bbf2b0ebeac0ebe --- /dev/null +++ b/vendors/irmin/src/irmin-git/contents.mli @@ -0,0 +1,28 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Backend module: turn a Git store into an Irmin backend for Git blobs. *) + +module Make (G : Git.S) (C : Irmin.Contents.S) : sig + include + Irmin.Content_addressable.S + with type _ t = bool ref * G.t + and type key = G.Hash.t + and type value = C.t + + module Hash : Irmin.Hash.S with type t = key + module Val : Irmin.Contents.S with type t = value +end diff --git a/vendors/irmin/src/irmin-git/dune b/vendors/irmin/src/irmin-git/dune new file mode 100644 index 0000000000000000000000000000000000000000..4e03acfc5e2f0401807064f4e124803f6bc38c97 --- /dev/null +++ b/vendors/irmin/src/irmin-git/dune @@ -0,0 +1,8 @@ +(library + (name irmin_git) + (public_name irmin-git) + (libraries astring cstruct fmt fpath git irmin logs lwt uri irmin.mem mimic) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-git/import.ml b/vendors/irmin/src/irmin-git/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..464589ac6082e439e64baf5ce035f6bd5dba1527 --- /dev/null +++ b/vendors/irmin/src/irmin-git/import.ml @@ -0,0 +1,22 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends + +let src = Logs.Src.create "irmin.git" ~doc:"Irmin Git-format store" + +module Log = (val Logs.src_log src : Logs.LOG) diff --git a/vendors/irmin/src/irmin-git/irmin_git.ml b/vendors/irmin/src/irmin-git/irmin_git.ml new file mode 100644 index 0000000000000000000000000000000000000000..196284d3fccfc41ea3c9d45df409c069fcfb8aba --- /dev/null +++ b/vendors/irmin/src/irmin-git/irmin_git.ml @@ -0,0 +1,346 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin_git_intf +open! Import +module Conf = Conf +module Metadata = Metadata +module Branch = Branch +module Reference = Reference +module Schema = Schema + +let config = Conf.init + +type reference = Reference.t [@@deriving irmin] + +module Maker_ext + (G : G) + (S : Git.Sync.S with type hash := G.hash and type store := G.t) = +struct + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + + module Make + (Schema : Schema.S + with type Hash.t = G.hash + and type Node.t = G.Value.Tree.t + and type Commit.t = G.Value.Commit.t) = + struct + module B = Backend.Make (G) (S) (Schema) + include Irmin.Of_backend (B) + + let git_of_repo = B.git_of_repo + let repo_of_git = B.repo_of_git + + let git_commit (repo : Repo.t) (h : commit) : G.Value.Commit.t option Lwt.t + = + let h = Commit.hash h in + G.read (git_of_repo repo) h >|= function + | Ok (Git.Value.Commit c) -> Some c + | _ -> None + + module Git = G + end +end + +module Mem = struct + include Git.Mem.Store + + let confs = Hashtbl.create 10 + let find_conf c = Hashtbl.find_opt confs c + + let add_conf c t = + Hashtbl.replace confs c t; + t + + let v' ?dotgit root = v ?dotgit root + + let v ?dotgit root = + let conf = (dotgit, root) in + match find_conf conf with + | Some x -> Lwt.return x + | None -> v' ?dotgit root >|= add_conf conf +end + +module Maker + (G : G) + (S : Git.Sync.S with type hash := G.hash and type store := G.t) = +struct + module Maker = Maker_ext (G) (S) + + type endpoint = Maker.endpoint + + module Make + (Sc : Schema.S + with type Hash.t = G.hash + and type Node.t = G.Value.Tree.t + and type Commit.t = G.Value.Commit.t) = + Maker.Make (Sc) +end + +module No_sync = struct + type error = + [ `Not_found | `Msg of string | `Exn of exn | `Cycle | `Invalid_flow ] + + let pp_error _ _ = assert false + + let fetch ?push_stdout:_ ?push_stderr:_ ?threads:_ ~ctx:_ _ _ ?version:_ + ?capabilities:_ ?deepen:_ _ = + assert false + + let push ~ctx:_ _ _ ?version:_ ?capabilities:_ _ = assert false +end + +module Content_addressable (G : Git.S) = struct + module G = struct + include G + + let v ?dotgit:_ _root = assert false + end + + module type S = Irmin.Content_addressable.S with type key = G.Hash.t + + module Maker = Maker_ext (G) (No_sync) + + module Make (V : Irmin.Type.S) = struct + module V = struct + include V + + let merge = Irmin.Merge.default Irmin.Type.(option V.t) + end + + module Schema = Schema.Make (G) (V) (Reference) + module M = Maker.Make (Schema) + module X = M.Backend.Contents + + let state t = + let+ r = M.repo_of_git (snd t) in + M.Backend.Repo.contents_t r + + type 'a t = bool ref * G.t + type key = X.key + type value = X.value + + let with_state0 f t = + let* t = state t in + f t + + let with_state1 f t x = + let* t = state t in + f t x + + let add = with_state1 X.add + let pp_key = Irmin.Type.pp X.Key.t + let equal_key = Irmin.Type.(unstage (equal X.Key.t)) + + let unsafe_add t k v = + let+ k' = with_state1 X.add t v in + if equal_key k k' then () + else + Fmt.failwith + "[Git.unsafe_append] %a is not a valid key. Expecting %a instead.\n" + pp_key k pp_key k' + + let find = with_state1 X.find + let mem = with_state1 X.mem + let close = with_state0 X.close + let batch t f = f t + end +end + +module Atomic_write (G : Git.S) = struct + module type S = Irmin.Atomic_write.S with type value = G.Hash.t + + module Make (K : Irmin.Branch.S) = struct + module K = struct + include K + + let main = + match Irmin.Type.of_string K.t "main" with + | Ok x -> x + | Error (`Msg e) -> failwith e + end + + module AW = Atomic_write.Make (Branch.Make (K)) (G) + include Atomic_write.Check_closed (AW) + end +end + +module KV + (G : G) + (S : Git.Sync.S with type hash := G.hash and type store := G.t) = +struct + module Maker = Maker (G) (S) + module Branch = Branch.Make (Irmin.Branch.String) + include Irmin.Key.Store_spec.Hash_keyed + + type endpoint = Maker.endpoint + type metadata = Metadata.t + type branch = Branch.t + type hash = G.hash + + module Make (C : Irmin.Contents.S) = Maker.Make (Schema.Make (G) (C) (Branch)) +end + +module Ref + (G : G) + (S : Git.Sync.S with type hash := G.hash and type store := G.t) = +struct + module Maker = Maker_ext (G) (S) + + type endpoint = Maker.endpoint + type branch = reference + + module Make (C : Irmin.Contents.S) = + Maker.Make (Schema.Make (G) (C) (Reference)) +end + +include Conf + +module Generic_KV + (CA : Irmin.Content_addressable.Maker) + (AW : Irmin.Atomic_write.Maker) = +struct + module G = Mem + + type endpoint = unit + type metadata = Metadata.t + type hash = G.hash + + include Irmin.Key.Store_spec.Hash_keyed + + module Schema (C : Irmin.Contents.S) = struct + module Metadata = Metadata + module Contents = C + module Path = Irmin.Path.String_list + module Branch = Branch.Make (Irmin.Branch.String) + module Hash = Irmin.Hash.Make (Mem.Hash) + module Node = Node.Make (G) (Path) + module Commit = Commit.Make (G) + module Info = Irmin.Info.Default + end + + module Make (C : Irmin.Contents.S) = struct + module Sc = Schema (C) + + (* We use a dummy store to get the serialisation functions. This is + probably not necessary and we could use Git.Value.Raw instead. *) + module Dummy = struct + module G = Mem + module Maker = Maker (G) (No_sync) + module S = Maker.Make (Sc) + include S.Backend + end + + module CA = Irmin.Content_addressable.Check_closed (CA) + module AW = Irmin.Atomic_write.Check_closed (AW) + + module X = struct + module Schema = Sc + module Hash = Dummy.Hash + module Info = Irmin.Info.Default + module Key = Irmin.Key.Of_hash (Hash) + + module Contents = struct + module V = Dummy.Contents.Val + module CA = CA (Hash) (V) + include Irmin.Contents.Store (CA) (Hash) (V) + end + + module Node = struct + module V = Dummy.Node.Val + module CA = CA (Hash) (V) + + include + Irmin.Node.Store (Contents) (CA) (Hash) (V) (Dummy.Node.Metadata) + (Schema.Path) + end + + module Node_portable = Irmin.Node.Portable.Of_node (Node.Val) + + module Commit = struct + module V = struct + include Dummy.Commit.Val + module Info = Schema.Info + + type hash = Hash.t [@@deriving irmin] + end + + module CA = CA (Hash) (V) + include Irmin.Commit.Store (Info) (Node) (CA) (Hash) (V) + end + + module Commit_portable = Irmin.Commit.Portable.Of_commit (Commit.V) + + module Branch = struct + module Key = Dummy.Branch.Key + module Val = Dummy.Branch.Val + include AW (Key) (Val) + end + + module Slice = Dummy.Slice + module Remote = Irmin.Backend.Remote.None (Branch.Val) (Branch.Key) + + module Repo = struct + (* FIXME: remove duplication with irmin.mli *) + type t = { + config : Irmin.config; + contents : read Contents.t; + nodes : read Node.t; + commits : read Commit.t; + branch : Branch.t; + } + + let contents_t t = t.contents + let node_t t = t.nodes + let commit_t t = t.commits + let branch_t t = t.branch + let config t = t.config + + let batch t f = + Contents.CA.batch t.contents @@ fun c -> + Node.CA.batch (snd t.nodes) @@ fun n -> + Commit.CA.batch (snd t.commits) @@ fun ct -> + let contents_t = c in + let node_t = (contents_t, n) in + let commit_t = (node_t, ct) in + f contents_t node_t commit_t + + let v config = + let* contents = Contents.CA.v config in + let* nodes = Node.CA.v config in + let* commits = Commit.CA.v config in + let nodes = (contents, nodes) in + let commits = (nodes, commits) in + let+ branch = Branch.v config in + { contents; nodes; commits; branch; config } + + let close t = + Contents.CA.close t.contents >>= fun () -> + Node.CA.close (snd t.nodes) >>= fun () -> + Commit.CA.close (snd t.commits) >>= fun () -> Branch.close t.branch + end + end + + include Irmin.Of_backend (X) + end +end + +(* Enforce that {!KV} is a sub-type of {!Irmin.KV_maker}. *) +module KV_is_a_KV_maker : Irmin.KV_maker = KV (Mem) (No_sync) + +(* Enforce that {!Generic_KV} is a sub-type of {!Irmin.KV_maker}. *) +module Generic_KV_is_a_KV_maker : Irmin.KV_maker = + Generic_KV (Irmin_mem.Content_addressable) (Irmin_mem.Atomic_write) diff --git a/vendors/irmin/src/irmin-git/irmin_git.mli b/vendors/irmin/src/irmin-git/irmin_git.mli new file mode 100644 index 0000000000000000000000000000000000000000..a37f3b9cb17f22f0b9c1a01cbe926640a91b1601 --- /dev/null +++ b/vendors/irmin/src/irmin-git/irmin_git.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Git backend *) + +include Irmin_git_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-git/irmin_git_intf.ml b/vendors/irmin/src/irmin-git/irmin_git_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..1c3813fc7e5e14e2a5c568244fc5f32c1278725c --- /dev/null +++ b/vendors/irmin/src/irmin-git/irmin_git_intf.ml @@ -0,0 +1,155 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type G = sig + include Git.S + + val v : ?dotgit:Fpath.t -> Fpath.t -> (t, error) result Lwt.t +end + +module type S = sig + (** The Git backend specializes a few types: + + - the allowed metadata are {!type-Metadata.t}. + - the hash algorithm is SHA1. *) + + module Git : Git.S + (** Access to the underlying Git store. *) + + module Schema : + Irmin.Schema.S with type Metadata.t = Metadata.t and type Hash.t = Git.hash + + include Irmin.S with type hash = Schema.Hash.t and module Schema := Schema + + val git_commit : Repo.t -> commit -> Git.Value.Commit.t option Lwt.t + (** [git_commit repo h] is the commit corresponding to [h] in the repository + [repo]. *) + + val git_of_repo : Repo.t -> Git.t + (** [of_repo r] is the Git store associated to [r]. *) + + val repo_of_git : + ?head:Git.Reference.t -> + ?bare:bool -> + ?lock:Lwt_mutex.t -> + Git.t -> + Repo.t Lwt.t + (** [to_repo t] is the Irmin repository associated to [t]. *) +end + +(** Same as {!Irmin.Maker} but with a fixed hash (SHA1) and metadata (Git + metadata) implemtations. *) +module type Maker = sig + module G : G + + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + + module Make + (Schema : Schema.S + with type Hash.t = G.hash + and type Node.t = G.Value.Tree.t + and type Commit.t = G.Value.Commit.t) : + S + with module Git = G + and module Schema := Schema + and type Backend.Remote.endpoint = endpoint +end + +module type KV_maker = sig + module G : G + + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + type branch + + module Make (C : Irmin.Contents.S) : + S + with module Git = G + and type Schema.Contents.t = C.t + and type Schema.Metadata.t = Metadata.t + and type Schema.Info.t = Irmin.Info.default + and type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Hash.t = G.hash + and type Schema.Branch.t = branch + and type Backend.Remote.endpoint = endpoint +end + +module type Sigs = sig + module Metadata = Metadata + module Conf = Conf + module Branch = Branch + module Reference = Reference + module Schema = Schema + + (** {2 Module types} *) + + module type G = G + module type S = S + module type Maker = Maker + module type KV_maker = KV_maker + + val config : + ?head:Git.Reference.t -> + ?bare:bool -> + ?level:int -> + ?dot_git:string -> + ?buffers:int -> + string -> + Irmin.config + + type reference = Reference.t [@@deriving irmin] + + module Content_addressable (G : Git.S) : sig + (** Use Git as a content-addressable store. Values will be stored into + [.git/objects].*) + + module type S = Irmin.Content_addressable.S with type key = G.Hash.t + + module Make (V : Irmin.Type.S) : S with type value = V.t + end + + module Atomic_write (G : Git.S) : sig + (** Use Git as an atomic-write store. Values will be stored into + [.git/refs]. When using the Git filesystem backend, branch names .*) + + module type S = Irmin.Atomic_write.S with type value = G.Hash.t + + module Make (K : Irmin.Branch.S) : S with type key = K.t + end + + module Maker + (G : G) + (S : Git.Sync.S with type hash := G.hash and type store := G.t) : + Maker with module G := G + + module KV + (G : G) + (S : Git.Sync.S with type hash := G.hash and type store := G.t) : + KV_maker with module G := G and type branch = string + + module Ref + (G : G) + (S : Git.Sync.S with type hash := G.hash and type store := G.t) : + KV_maker with module G := G and type branch = Reference.t + + module Generic_KV + (CA : Irmin.Content_addressable.Maker) + (AW : Irmin.Atomic_write.Maker) : Irmin.KV_maker with type endpoint = unit + + (** In-memory Git store. *) + module Mem : + G with type t = Digestif.SHA1.t Git.Mem.t and type hash = Digestif.SHA1.t +end diff --git a/vendors/irmin/src/irmin-git/metadata.ml b/vendors/irmin/src/irmin-git/metadata.ml new file mode 100644 index 0000000000000000000000000000000000000000..17c87cd01040d08002eb31b44e50bc9461940fcf --- /dev/null +++ b/vendors/irmin/src/irmin-git/metadata.ml @@ -0,0 +1,33 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module X = struct + type t = [ `Normal | `Exec | `Link | `Everybody ] + + let t = + Irmin.Type.enum "metadata" + [ + ("normal", `Normal); + ("exec", `Exec); + ("link", `Link); + ("everybody", `Everybody); + ] +end + +include X + +let default = `Normal +let merge = Irmin.Merge.default X.t diff --git a/vendors/irmin/src/irmin-git/metadata.mli b/vendors/irmin/src/irmin-git/metadata.mli new file mode 100644 index 0000000000000000000000000000000000000000..f57547a3580c2d08af6cc524988c5addcf2aadd1 --- /dev/null +++ b/vendors/irmin/src/irmin-git/metadata.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type t = [ `Normal | `Exec | `Link | `Everybody ] + +include Irmin.Metadata.S with type t := t diff --git a/vendors/irmin/src/irmin-git/node.ml b/vendors/irmin/src/irmin-git/node.ml new file mode 100644 index 0000000000000000000000000000000000000000..a0d24595fc22a17667f50e9b1106d5114d17eae6 --- /dev/null +++ b/vendors/irmin/src/irmin-git/node.ml @@ -0,0 +1,204 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +module Make (G : Git.S) (P : Irmin.Path.S) = struct + module Hash = Irmin.Hash.Make (G.Hash) + module Key = Irmin.Key.Of_hash (Hash) + module Raw = Git.Value.Make (G.Hash) + module Path = P + module Metadata = Metadata + + type t = G.Value.Tree.t + type metadata = Metadata.t [@@deriving irmin] + type hash = Hash.t [@@deriving irmin] + type step = Path.step [@@deriving irmin] + type node_key = hash [@@deriving irmin] + type contents_key = hash [@@deriving irmin] + + type value = [ `Node of hash | `Contents of hash * metadata ] + [@@deriving irmin] + + let of_step = Irmin.Type.to_string P.step_t + + let to_step str = + match Irmin.Type.of_string P.step_t str with + | Ok x -> x + | Error (`Msg e) -> failwith e + + exception Exit of (step * value) list + + let list ?(offset = 0) ?length ?cache:_ t = + let t = G.Value.Tree.to_list t in + let length = match length with None -> List.length t | Some n -> n in + try + List.fold_left + (fun (i, acc) { Git.Tree.perm; name; node } -> + if i < offset then (i + 1, acc) + else if i >= offset + length then raise (Exit acc) + else + let name = to_step name in + match perm with + | `Dir -> (i + 1, (name, `Node node) :: acc) + | `Commit -> (i + 1, acc) (* FIXME *) + | #Metadata.t as p -> (i + 1, (name, `Contents (node, p)) :: acc)) + (0, []) t + |> fun (_, acc) -> List.rev acc + with Exit acc -> List.rev acc + + let find ?cache:_ t s = + let s = of_step s in + let rec aux = function + | [] -> None + | x :: xs when x.Git.Tree.name <> s -> aux xs + | { Git.Tree.perm; node; _ } :: _ -> ( + match perm with + | `Dir -> Some (`Node node) + | `Commit -> None (* FIXME *) + | #Metadata.t as p -> Some (`Contents (node, p))) + in + aux (Git.Tree.to_list t) + + let remove t step = G.Value.Tree.remove ~name:(of_step step) t + let is_empty = G.Value.Tree.is_empty + let length t = G.Value.Tree.length t |> Int64.to_int + + let add t name value = + let name = of_step name in + let entry = + match value with + | `Node node -> Git.Tree.entry ~name `Dir node + | `Contents (node, perm) -> + Git.Tree.entry ~name (perm :> Git.Tree.perm) node + in + (* FIXME(samoht): issue in G.Value.Tree.add *) + let entries = G.Value.Tree.to_list t in + match List.find (fun e -> e.Git.Tree.name = name) entries with + | exception Not_found -> Git.Tree.of_list (entry :: entries) + | e -> + let equal x y = + x.Git.Tree.perm = y.Git.Tree.perm + && x.name = y.name + && G.Hash.equal x.node y.node + in + if equal e entry then t + else + let entries = + List.filter (fun e -> e.Git.Tree.name <> name) entries + in + Git.Tree.of_list (entry :: entries) + + let empty : unit -> t = + (* [Git.Tree.t] is immutable, so sharing a singleton empty tree is safe *) + Fun.const (Git.Tree.of_list []) + + let to_git perm (name, node) = + G.Value.Tree.entry ~name:(of_step name) perm node + + let v alist = + let alist = + List.rev_map + (fun (l, x) -> + let v k = (l, k) in + match x with + | `Node n -> to_git `Dir (v n) + | `Contents (c, perm) -> to_git (perm :> Git.Tree.perm) (v c)) + alist + in + (* Tree.of_list will sort the list in the right order *) + G.Value.Tree.of_list alist + + let alist t = + let mk_n k = `Node k in + let mk_c k metadata = `Contents (k, metadata) in + List.fold_left + (fun acc -> function + | { Git.Tree.perm = `Dir; name; node } -> + (to_step name, mk_n node) :: acc + | { Git.Tree.perm = `Commit; name; _ } -> + (* Irmin does not support Git submodules; do not follow them, + just consider *) + [%log.warn "skipping Git submodule: %s" name]; + acc + | { Git.Tree.perm = #Metadata.t as perm; name; node; _ } -> + (to_step name, mk_c node perm) :: acc) + [] (G.Value.Tree.to_list t) + |> List.rev + + module N = Irmin.Node.Make (Hash) (P) (Metadata) + + let to_n t = N.of_list (alist t) + let of_n n = v (N.list n) + let to_bin t = Raw.to_raw (G.Value.tree t) + let of_list = v + let of_seq seq = List.of_seq seq |> v + + let seq ?offset ?length ?cache t = + list ?offset ?length ?cache t |> List.to_seq + + let clear _ = () + + let encode_bin (t : t) k = + [%log.debug "Tree.encode_bin"]; + k (to_bin t) + + let decode_bin buf pos_ref = + [%log.debug "Tree.decode_bin"]; + let off = !pos_ref in + match Raw.of_raw_with_header buf ~off with + | Ok (Git.Value.Tree t) -> + pos_ref := String.length buf; + t + | Ok _ -> failwith "wrong object kind" + | Error _ -> failwith "wrong object" + + let size_of = Irmin.Type.Size.custom_dynamic () + let t = Irmin.Type.map ~bin:(encode_bin, decode_bin, size_of) N.t of_n to_n + + let merge ~contents ~node = + let merge = N.merge ~contents ~node in + Irmin.Merge.like t merge to_n of_n + + exception Dangling_hash of { context : string; hash : hash } + + let with_handler _ n = n + let head t = `Node (list t) + + module Ht = + Irmin.Hash.Typed + (Hash) + (struct + type nonrec t = t [@@deriving irmin] + end) + + let hash_exn ?force:_ = Ht.hash +end + +module Store (G : Git.S) (P : Irmin.Path.S) = struct + module Key = Irmin.Hash.Make (G.Hash) + module Val = Make (G) (P) + + module V = struct + type t = G.Value.Tree.t + + let type_eq = function `Tree -> true | _ -> false + let to_git t = G.Value.tree t + let of_git = function Git.Value.Tree t -> Some t | _ -> None + end + + include Content_addressable.Check_closed (Content_addressable.Make (G) (V)) +end diff --git a/vendors/irmin/src/irmin-git/node.mli b/vendors/irmin/src/irmin-git/node.mli new file mode 100644 index 0000000000000000000000000000000000000000..4514c7e4b33a7067c5068a5562ab50d82c18ed6a --- /dev/null +++ b/vendors/irmin/src/irmin-git/node.mli @@ -0,0 +1,41 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Backend module: turn a Git store into an Irmin backend for Git trees. *) + +module Make (G : Git.S) (P : Irmin.Path.S) : + Irmin.Node.S + with type t = G.Value.Tree.t + and type hash = G.hash + and type step = P.step + and type metadata = Metadata.t + +module Store (G : Git.S) (P : Irmin.Path.S) : sig + include + Irmin.Content_addressable.S + with type _ t = bool ref * G.t + and type key = G.Hash.t + and type value = G.Value.Tree.t + + module Key : Irmin.Hash.S with type t = key + + module Val : + Irmin.Node.S + with type t = value + and type hash = key + and type step = P.step + and type metadata = Metadata.t +end diff --git a/vendors/irmin/src/irmin-git/reference.ml b/vendors/irmin/src/irmin-git/reference.ml new file mode 100644 index 0000000000000000000000000000000000000000..cc36327816017cf56f9566f88a3798012a521abd --- /dev/null +++ b/vendors/irmin/src/irmin-git/reference.ml @@ -0,0 +1,45 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Astring + +module type S = Atomic_write.Key + +type t = + [ `Branch of string | `Remote of string | `Tag of string | `Other of string ] +[@@deriving irmin] + +let pp_ref ppf = function + | `Branch b -> Fmt.pf ppf "refs/heads/%s" b + | `Remote r -> Fmt.pf ppf "refs/remotes/%s" r + | `Tag t -> Fmt.pf ppf "refs/tags/%s" t + | `Other o -> Fmt.pf ppf "refs/%s" o + +let path l = String.concat ~sep:"/" l + +let of_ref str = + match String.cuts ~sep:"/" str with + | "refs" :: "heads" :: b -> Ok (`Branch (path b)) + | "refs" :: "remotes" :: r -> Ok (`Remote (path r)) + | "refs" :: "tags" :: t -> Ok (`Tag (path t)) + | "refs" :: o -> Ok (`Other (path o)) + | _ -> Error (`Msg (Fmt.str "%s is not a valid reference" str)) + +let t = Irmin.Type.like t ~pp:pp_ref ~of_string:of_ref +let main = `Branch Irmin.Branch.String.main + +let is_valid = function + | `Branch s | `Tag s | `Remote s | `Other s -> Irmin.Branch.String.is_valid s diff --git a/vendors/irmin/src/irmin-git/reference.mli b/vendors/irmin/src/irmin-git/reference.mli new file mode 100644 index 0000000000000000000000000000000000000000..703f1241f63239f808ec3ad3a1fd1fc70584706f --- /dev/null +++ b/vendors/irmin/src/irmin-git/reference.mli @@ -0,0 +1,30 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** one-to-one mapping between Irmin and Git references. *) + +module type S = sig + include Atomic_write.Key + (** @inline *) +end + +type t = + [ `Branch of string | `Remote of string | `Tag of string | `Other of string ] +[@@deriving irmin] +(** The type for Git references. Use the {!Branch} module to only deal with + [`Branch] values. *) + +include S with type t := t diff --git a/vendors/irmin/src/irmin-git/remote.ml b/vendors/irmin/src/irmin-git/remote.ml new file mode 100644 index 0000000000000000000000000000000000000000..d357af18e11eb4afc5fd78673fc008d1c619d750 --- /dev/null +++ b/vendors/irmin/src/irmin-git/remote.ml @@ -0,0 +1,99 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +let ( >>? ) = Lwt_result.bind + +module Make + (G : Git.S) + (S : Git.Sync.S with type hash := G.hash and type store := G.t) + (B : Irmin.Branch.S) = +struct + let src = Logs.Src.create "irmin.git-remote" ~doc:"Git remote" + + module Gitlog = (val Logs.src_log src : Logs.LOG) + module H = Irmin.Hash.Make (G.Hash) + + type t = G.t + type commit = H.t + type branch = B.t + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + + let git_of_branch_str str = Git.Reference.v ("refs/heads/" ^ str) + let git_of_branch r = git_of_branch_str (Irmin.Type.to_string B.t r) + + (* let o_head_of_git = function None -> Ok None | Some k -> Ok (Some k) *) + + let msgf fmt = Fmt.kstr (fun err -> `Msg err) fmt + let reword_error f = function Ok _ as v -> v | Error err -> Error (f err) + + let fetch t ?depth (ctx, e) br = + [%log.debug "fetch %a" Smart_git.Endpoint.pp e]; + let push_stdout msg = Gitlog.info (fun f -> f "%s" msg) + and push_stderr msg = Gitlog.warn (fun f -> f "%s" msg) + and deepen = + match depth with Some depth -> Some (`Depth depth) | None -> None + and reference = git_of_branch br + and capabilities = + [ + `Side_band_64k; + `Multi_ack_detailed; + `Ofs_delta; + `Thin_pack; + `Report_status; + ] + in + S.fetch ~push_stdout ~push_stderr ~capabilities ~ctx e t ?deepen + (`Some [ (reference, reference) ]) + >>= function + | Error `Not_found -> Lwt.return (Error (`Msg "not found")) + | Error (`Msg err) -> Lwt.return (Error (`Msg err)) + | Error (`Exn err) -> Lwt.return (Error (`Msg (Printexc.to_string err))) + | Error err -> + Fmt.kstr (fun e -> Lwt.return (Error (`Msg e))) "%a" S.pp_error err + | Ok None -> Lwt.return (Ok None) + | Ok (Some (_, [ (reference, hash) ])) -> + let value = Git.Reference.uid hash in + let br = + Git.Reference.v ("refs/remotes/origin/" ^ Irmin.Type.to_string B.t br) + in + G.Ref.write t br value >|= reword_error (msgf "%a" G.pp_error) + >>? fun () -> + G.Ref.write t reference value >|= reword_error (msgf "%a" G.pp_error) + >>? fun () -> Lwt.return (Ok (Some hash)) + | _ -> assert false + + let push t ?depth:_ (ctx, e) br = + [%log.debug "push %a" Smart_git.Endpoint.pp e]; + let reference = git_of_branch br in + let capabilities = + [ + `Side_band_64k; + `Multi_ack_detailed; + `Ofs_delta; + `Thin_pack; + `Report_status; + ] + in + S.push ~capabilities ~ctx e t [ `Update (reference, reference) ] + >|= function + | Error (`Msg err) -> Error (`Msg err) + | Error (`Exn exn) -> Error (`Msg (Printexc.to_string exn)) + | Error `Not_found -> Error (`Msg "not found") + | Error err -> Error (`Msg (Fmt.str "%a" S.pp_error err)) + | Ok () -> Ok () +end diff --git a/vendors/irmin/src/irmin-git/remote.mli b/vendors/irmin/src/irmin-git/remote.mli new file mode 100644 index 0000000000000000000000000000000000000000..341b0b73f52adaafc1777ddd2b3e7f17de0cf288 --- /dev/null +++ b/vendors/irmin/src/irmin-git/remote.mli @@ -0,0 +1,25 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make + (G : Git.S) + (S : Git.Sync.S with type hash := G.hash and type store := G.t) + (B : Irmin.Branch.S) : + Irmin.Backend.Remote.S + with type commit = G.hash + and type branch = B.t + and type t = G.t + and type endpoint = Mimic.ctx * Smart_git.Endpoint.t diff --git a/vendors/irmin/src/irmin-git/schema.ml b/vendors/irmin/src/irmin-git/schema.ml new file mode 100644 index 0000000000000000000000000000000000000000..66a6fec3913f5d7554ee1fa3ccc3ffef298d4a92 --- /dev/null +++ b/vendors/irmin/src/irmin-git/schema.ml @@ -0,0 +1,52 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + module Branch : Branch.S + + include + Irmin.Schema.S + with module Metadata = Metadata + and module Branch := Branch + and type Info.t = Irmin.Info.default + and type Path.step = string + and type Path.t = string list + + module Node : + Irmin.Node.S + with type metadata = Metadata.t + and type step = Path.step + and type hash = Hash.t + + module Commit : Irmin.Commit.S with module Info := Info and type hash = Hash.t +end + +module Make (G : Git.S) (V : Irmin.Contents.S) (B : Branch.S) : + S + with type Hash.t = G.hash + and module Contents = V + and module Branch = B + and type Node.t = G.Value.Tree.t + and type Commit.t = G.Value.Commit.t = struct + module Metadata = Metadata + module Contents = V + module Path = Irmin.Path.String_list + module Branch = B + module Hash = Irmin.Hash.Make (G.Hash) + module Node = Node.Make (G) (Path) + module Commit = Commit.Make (G) + module Info = Irmin.Info.Default +end diff --git a/vendors/irmin/src/irmin-git/unix/dune b/vendors/irmin/src/irmin-git/unix/dune new file mode 100644 index 0000000000000000000000000000000000000000..3947e48d5d3fb7c07682a4380bce528957706d81 --- /dev/null +++ b/vendors/irmin/src/irmin-git/unix/dune @@ -0,0 +1,8 @@ +(library + (public_name irmin-git.unix) + (name irmin_git_unix) + (libraries cohttp-lwt-unix git-unix irmin-git irmin.unix lwt.unix) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-git/unix/irmin_git_unix.ml b/vendors/irmin/src/irmin-git/unix/irmin_git_unix.ml new file mode 100644 index 0000000000000000000000000000000000000000..6c9dbdabe15f954b023e24f3a71fcc84d0d95ecc --- /dev/null +++ b/vendors/irmin/src/irmin-git/unix/irmin_git_unix.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Xgit +include Irmin_unix diff --git a/vendors/irmin/src/irmin-git/unix/xgit.ml b/vendors/irmin/src/irmin-git/unix/xgit.ml new file mode 100644 index 0000000000000000000000000000000000000000..4b8489b8775a753826c37093fab36da415e373af --- /dev/null +++ b/vendors/irmin/src/irmin-git/unix/xgit.ml @@ -0,0 +1,91 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt.Syntax +include Xgit_intf + +let src = Logs.Src.create "git.unix" ~doc:"logs git's unix events" + +module Log = (val Logs.src_log src : Logs.LOG) + +let remote ?ctx ?headers uri = + let+ ctx = + match ctx with + | Some x -> Lwt.return x + | None -> Git_unix.ctx (Happy_eyeballs_lwt.create ()) + in + let ( ! ) f a b = f b a in + let headers = Option.map Cohttp.Header.to_list headers in + match Smart_git.Endpoint.of_string uri with + | Ok edn -> + let edn = + Option.fold ~none:edn + ~some:(!Smart_git.Endpoint.with_headers_if_http edn) + headers + in + (ctx, edn) + | Error (`Msg err) -> Fmt.invalid_arg "remote: %s" err + +module Maker (G : Irmin_git.G) = struct + module G = G + + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + + module Maker = struct + module S = Irmin_git.Maker (G) (Git_unix.Sync (G)) + module KV = Irmin_git.KV (G) (Git_unix.Sync (G)) + module Ref = Irmin_git.Ref (G) (Git_unix.Sync (G)) + end + + module Make + (S : Irmin_git.Schema.S + with type Hash.t = G.hash + and type Node.t = G.Value.Tree.t + and type Commit.t = G.Value.Commit.t) = + struct + include Maker.S.Make (S) + + let remote ?ctx ?headers uri = + let+ e = remote ?ctx ?headers uri in + E e + end + + module KV (C : Irmin.Contents.S) = struct + include Maker.KV.Make (C) + + let remote ?ctx ?headers uri = + let+ e = remote ?ctx ?headers uri in + E e + end + + module Ref (C : Irmin.Contents.S) = struct + include Maker.Ref.Make (C) + + let remote ?ctx ?headers uri = + let+ e = remote ?ctx ?headers uri in + E e + end +end + +module FS = struct + include Maker (Git_unix.Store) + module G = Git_unix.Store +end + +module Mem = struct + include Maker (Irmin_git.Mem) + module G = Irmin_git.Mem +end diff --git a/vendors/irmin/src/irmin-git/unix/xgit.mli b/vendors/irmin/src/irmin-git/unix/xgit.mli new file mode 100644 index 0000000000000000000000000000000000000000..7b34325a4b7c191911ec11c7bc056e5d5b62034b --- /dev/null +++ b/vendors/irmin/src/irmin-git/unix/xgit.mli @@ -0,0 +1,22 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Xgit_intf.Sigs +(** @inline *) + +module Maker (G : G) : Backend with module G = G +module FS : Backend with module G = Git_unix.Store +module Mem : Backend with module G = Irmin_git.Mem diff --git a/vendors/irmin/src/irmin-git/unix/xgit_intf.ml b/vendors/irmin/src/irmin-git/unix/xgit_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..dcaa9b4f215bdd4c7c5b8b13085cf6c063c74e6f --- /dev/null +++ b/vendors/irmin/src/irmin-git/unix/xgit_intf.ml @@ -0,0 +1,78 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type G = sig + include Git.S + + val v : ?dotgit:Fpath.t -> Fpath.t -> (t, error) result Lwt.t +end + +module type S = sig + include + Irmin_git.S + with type Backend.Remote.endpoint = Mimic.ctx * Smart_git.Endpoint.t + + val remote : + ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t +end + +module type Backend = sig + (* FIXME: remove signature duplication *) + + module G : Irmin_git.G + + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + + module Make + (Schema : Irmin_git.Schema.S + with type Hash.t = G.hash + and type Node.t = G.Value.Tree.t + and type Commit.t = G.Value.Commit.t) : + S + with module Git = G + and type Backend.Remote.endpoint = endpoint + and module Schema := Schema + + module KV (C : Irmin.Contents.S) : + S + with module Git = G + and type Schema.Contents.t = C.t + and type Schema.Metadata.t = Irmin_git.Metadata.t + and type Schema.Info.t = Irmin.Info.default + and type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Hash.t = G.hash + and type Schema.Branch.t = string + and type Backend.Remote.endpoint = endpoint + + module Ref (C : Irmin.Contents.S) : + S + with module Git = G + and type Schema.Contents.t = C.t + and type Schema.Metadata.t = Irmin_git.Metadata.t + and type Schema.Info.t = Irmin.Info.default + and type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Hash.t = G.hash + and type Schema.Branch.t = Irmin_git.reference + and type Backend.Remote.endpoint = endpoint +end + +module type Sigs = sig + module type G = G + module type S = S + module type Backend = Backend +end diff --git a/vendors/irmin/src/irmin-git/value.ml b/vendors/irmin/src/irmin-git/value.ml new file mode 100644 index 0000000000000000000000000000000000000000..0d3e97d312c9a78b77daf23054b133c936a7414b --- /dev/null +++ b/vendors/irmin/src/irmin-git/value.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Value_intf diff --git a/vendors/irmin/src/irmin-git/value.mli b/vendors/irmin/src/irmin-git/value.mli new file mode 100644 index 0000000000000000000000000000000000000000..fcce43ffaeb0b2392387820bc9f96519a6c68440 --- /dev/null +++ b/vendors/irmin/src/irmin-git/value.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Value_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-git/value_intf.ml b/vendors/irmin/src/irmin-git/value_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..0c32e6442e1ead781907f626dab73b4a9638a810 --- /dev/null +++ b/vendors/irmin/src/irmin-git/value_intf.ml @@ -0,0 +1,28 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + type t + type value + + val type_eq : [ `Commit | `Blob | `Tree | `Tag ] -> bool + val to_git : t -> value + val of_git : value -> t option +end + +module type Sigs = sig + module type S = S +end diff --git a/vendors/irmin/src/irmin-graphql/dune b/vendors/irmin/src/irmin-graphql/dune new file mode 100644 index 0000000000000000000000000000000000000000..e5221faa3cf08c61e26629939a0aa9726be404a6 --- /dev/null +++ b/vendors/irmin/src/irmin-graphql/dune @@ -0,0 +1,15 @@ +(library + (name irmin_graphql) + (public_name irmin-graphql) + (libraries + fmt + cohttp + cohttp-lwt + graphql-cohttp + graphql + graphql-lwt + graphql_parser + irmin + lwt) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-graphql/import.ml b/vendors/irmin/src/irmin-graphql/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..71053e21ba54118af9da1fc7b37d45eb620c46e2 --- /dev/null +++ b/vendors/irmin/src/irmin-graphql/import.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/src/irmin-graphql/server.ml b/vendors/irmin/src/irmin-graphql/server.ml new file mode 100644 index 0000000000000000000000000000000000000000..dfe2838e88ce25bee81e3426260c7e4795a0ba2c --- /dev/null +++ b/vendors/irmin/src/irmin-graphql/server.ml @@ -0,0 +1,916 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module Schema = Graphql_lwt.Schema + +module type S = sig + module IO : Cohttp_lwt.S.IO + + type repo + type server + + type response_action = + [ `Expert of Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t) + | `Response of Cohttp.Response.t * Cohttp_lwt.Body.t ] + + val schema : repo -> unit Schema.schema + + val execute_request : + unit Schema.schema -> + Cohttp_lwt.Request.t -> + Cohttp_lwt.Body.t -> + response_action Lwt.t + + val v : repo -> server +end + +let of_irmin_result = function + | Ok _ as ok -> ok + | Error (`Msg msg) -> Error msg + +module Option = struct + let map f t = match t with None -> None | Some x -> Some (f x) +end + +module Result = struct + let ok x = Ok x +end + +module type CONFIG = sig + type info + + val remote : (?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t) option + + val info : + ?author:string -> ('a, Format.formatter, unit, unit -> info) format4 -> 'a +end + +module type CUSTOM_TYPE = sig + type t + + val schema_typ : (unit, t option) Schema.typ + val arg_typ : t option Schema.Arg.arg_typ +end + +module type CUSTOM_TYPES = sig + type path + type metadata + type contents + type hash + type branch + type commit_key + type node_key + type contents_key + + module Path : CUSTOM_TYPE with type t := path + module Metadata : CUSTOM_TYPE with type t := metadata + module Contents : CUSTOM_TYPE with type t := contents + module Hash : CUSTOM_TYPE with type t := hash + module Branch : CUSTOM_TYPE with type t := branch + module Commit_key : CUSTOM_TYPE with type t := commit_key + module Contents_key : CUSTOM_TYPE with type t := contents_key + module Node_key : CUSTOM_TYPE with type t := node_key +end + +module Default_type (T : sig + include Irmin.Type.S + + val name : string +end) = +struct + let schema_typ = + let coerce t = `String (Irmin.Type.to_string T.t t) in + Schema.scalar T.name ~coerce + + let arg_typ = + let coerce = function + | `String s -> of_irmin_result (Irmin.Type.of_string T.t s) + | _ -> Error "Invalid input value" + in + Schema.Arg.scalar T.name ~coerce +end + +module Default_types (S : Irmin.Generic_key.S) = struct + module Path = Default_type (struct + include S.Path + + let name = "Path" + end) + + module Metadata = Default_type (struct + include S.Metadata + + let name = "Metadata" + end) + + module Contents = Default_type (struct + include S.Contents + + let name = "Value" + end) + + module Hash = Default_type (struct + include S.Hash + + let name = "Hash" + end) + + module Branch = Default_type (struct + include S.Branch + + let name = "BranchName" + end) + + module Commit_key = Default_type (struct + type t = S.commit_key + + let t = S.commit_key_t + let name = "CommitKey" + end) + + module Node_key = Default_type (struct + type t = S.node_key + + let t = S.node_key_t + let name = "NodeKey" + end) + + module Contents_key = Default_type (struct + type t = S.contents_key + + let t = S.contents_key_t + let name = "ContentsKey" + end) +end + +module Make_ext + (Server : Cohttp_lwt.S.Server) + (Config : CONFIG) + (Store : Irmin.Generic_key.S with type Schema.Info.t = Config.info) + (Types : CUSTOM_TYPES + with type path := Store.path + and type metadata := Store.metadata + and type contents := Store.contents + and type hash := Store.hash + and type branch := Store.branch + and type commit_key := Store.commit_key + and type node_key := Store.node_key + and type contents_key := Store.contents_key) = +struct + module IO = Server.IO + module Sync = Irmin.Sync.Make (Store) + module Graphql_server = Graphql_cohttp.Make (Schema) (IO) (Cohttp_lwt.Body) + module Info = Store.Info + + type repo = Store.repo + type server = Server.t + type info = Store.info + + type txn_args = { + author : string option; + message : string option; + retries : int option; + allow_empty : bool option; + parents : Store.commit_key list option; + } + + let txn_args repo input = + match input with + | Some input -> + let message = match input.message with None -> "" | Some m -> m in + let author = input.author in + let parents = + match input.parents with + | Some l -> + Lwt_list.filter_map_s (Store.Commit.of_key repo) l + >>= Lwt.return_some + | None -> Lwt.return_none + in + let+ parents = parents in + ( Config.info ?author "%s" message, + input.retries, + input.allow_empty, + parents ) + | None -> Lwt.return (Config.info "", None, None, None) + + type response_action = + [ `Expert of Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t) + | `Response of Cohttp.Response.t * Cohttp_lwt.Body.t ] + + type tree_item = { + path : Store.path; + value : Store.contents option; + metadata : Store.metadata option; + } + + let mk_branch repo = function + | Some b -> Store.of_branch repo b + | None -> Store.main repo + + let rec concat_path a b = + match Store.Path.decons a with + | None -> b + | Some (step, a_tl) -> Store.Path.cons step (concat_path a_tl b) + + module Input = struct + let coerce_remote = function + | `String s -> ( + match Config.remote with + | Some remote -> Ok (remote s) + | None -> Error "sync is not available") + | _ -> Error "Invalid input value" + + let remote = Schema.Arg.(scalar "Remote" ~coerce:coerce_remote) + let path = Types.Path.arg_typ + let hash = Types.Hash.arg_typ + let commit_key = Types.Commit_key.arg_typ + let branch = Types.Branch.arg_typ + let value = Types.Contents.arg_typ + let metadata = Types.Metadata.arg_typ + let contents_key = Types.Contents_key.arg_typ + + let info = + Schema.Arg.( + obj "InfoInput" + ~fields: + [ + arg "author" ~typ:string; + arg "message" ~typ:string; + arg "retries" ~typ:int; + arg "allow_empty" ~typ:bool; + arg "parents" ~typ:(list (non_null commit_key)); + ] + ~coerce:(fun author message retries allow_empty parents -> + { author; message; retries; allow_empty; parents })) + + let item = + Schema.Arg.( + obj "TreeItem" + ~fields: + [ + arg "path" ~typ:(non_null path); + arg "value" ~typ:value; + arg "metadata" ~typ:metadata; + ] + ~coerce:(fun path value metadata -> { path; value; metadata })) + + let tree = Schema.Arg.(list (non_null item)) + end + + let rec commit = + lazy + Schema.( + obj "Commit" ~fields:(fun _ -> + [ + field "tree" + ~typ:(non_null (Lazy.force tree)) + ~args:[] + ~resolve:(fun _ c -> (Store.Commit.tree c, Store.Path.empty)); + field "parents" + ~typ:(non_null (list (non_null Types.Commit_key.schema_typ))) + ~args:[] + ~resolve:(fun _ c -> Store.Commit.parents c); + field "info" + ~typ:(non_null Lazy.(force info)) + ~args:[] + ~resolve:(fun _ c -> Store.Commit.info c); + field "hash" ~typ:(non_null Types.Hash.schema_typ) ~args:[] + ~resolve:(fun _ c -> Store.Commit.hash c); + field "key" ~typ:(non_null Types.Commit_key.schema_typ) ~args:[] + ~resolve:(fun _ c -> Store.Commit.key c); + ])) + + and info : ('ctx, info option) Schema.typ Lazy.t = + lazy + Schema.( + obj "Info" ~fields:(fun _info -> + [ + field "date" ~typ:(non_null string) ~args:[] ~resolve:(fun _ i -> + Info.date i |> Int64.to_string); + field "author" ~typ:(non_null string) ~args:[] + ~resolve:(fun _ i -> Info.author i); + field "message" ~typ:(non_null string) ~args:[] + ~resolve:(fun _ i -> Info.message i); + ])) + + and tree : ('ctx, (Store.tree * Store.path) option) Schema.typ Lazy.t = + lazy + Schema.( + obj "Tree" ~fields:(fun _ -> + [ + field "path" ~typ:(non_null Types.Path.schema_typ) ~args:[] + ~resolve:(fun _ (_, path) -> path); + io_field "get" + ~args:Arg.[ arg "path" ~typ:(non_null Input.path) ] + ~typ:Types.Contents.schema_typ + ~resolve:(fun _ (tree, _) path -> + Store.Tree.find tree path >|= Result.ok); + io_field "get_contents" + ~args:Arg.[ arg "path" ~typ:(non_null Input.path) ] + ~typ:Lazy.(force contents) + ~resolve:(fun _ (tree, tree_path) path -> + Store.Tree.find_all tree path + >|= Option.map (fun (c, m) -> + let path' = concat_path tree_path path in + (c, m, path')) + >|= Result.ok); + io_field "get_tree" + ~args:Arg.[ arg "path" ~typ:(non_null Input.path) ] + ~typ:Lazy.(force tree) + ~resolve:(fun _ (tree, tree_path) path -> + Store.Tree.find_tree tree path + >|= Option.map (fun tree -> + let tree_path' = concat_path tree_path path in + (tree, tree_path')) + >|= Result.ok); + io_field "list_contents_recursively" ~args:[] + ~typ:(non_null (list (non_null Lazy.(force contents)))) + ~resolve:(fun _ (tree, path) -> + let rec tree_list ?(acc = []) tree path = + match Store.Tree.destruct tree with + | `Contents (c, m) -> + Store.Tree.Contents.force_exn c >|= fun c -> + (c, m, path) :: acc + | `Node _ -> + let* l = Store.Tree.list tree Store.Path.empty in + Lwt_list.fold_left_s + (fun acc (step, t) -> + let path' = Store.Path.rcons path step in + tree_list t path' ~acc) + acc l + >|= List.rev + in + tree_list tree path >>= Lwt.return_ok); + field "hash" ~typ:(non_null Types.Hash.schema_typ) ~args:[] + ~resolve:(fun _ (tree, _) -> Store.Tree.hash tree); + field "key" ~typ:kinded_key ~args:[] ~resolve:(fun _ (tree, _) -> + match Store.Tree.key tree with + | Some (`Contents (k, m)) -> + Some (Lazy.force contents_key_as_kinded_key (k, m)) + | Some (`Node k) -> Some (Lazy.force node_key_as_kinded_key k) + | None -> None); + io_field "list" + ~typ:(non_null (list (non_null node))) + ~args:[] + ~resolve:(fun _ (tree, tree_path) -> + Store.Tree.list tree Store.Path.empty + >>= Lwt_list.map_s (fun (step, tree) -> + let absolute_path = Store.Path.rcons tree_path step in + match Store.Tree.destruct tree with + | `Contents (c, m) -> + let+ c = Store.Tree.Contents.force_exn c in + Lazy.( + force contents_as_node (c, m, absolute_path)) + | _ -> + Lwt.return + Lazy.(force tree_as_node (tree, absolute_path))) + >|= Result.ok); + ])) + + and branch : ('ctx, (Store.t * Store.Branch.t) option) Schema.typ Lazy.t = + lazy + Schema.( + obj "Branch" ~fields:(fun _branch -> + [ + field "name" ~typ:(non_null Types.Branch.schema_typ) ~args:[] + ~resolve:(fun _ (_, b) -> b); + io_field "head" ~args:[] ~typ:(Lazy.force commit) + ~resolve:(fun _ (t, _) -> Store.Head.find t >|= Result.ok); + io_field "tree" ~args:[] + ~typ:(non_null Lazy.(force tree)) + ~resolve:(fun _ (t, _) -> + let+ tree = Store.tree t in + Ok (tree, Store.Path.empty)); + io_field "last_modified" + ~typ:(non_null (list (non_null (Lazy.force commit)))) + ~args: + Arg. + [ + arg "path" ~typ:(non_null Input.path); + arg "depth" ~typ:int; + arg "n" ~typ:int; + ] + ~resolve:(fun _ (t, _) path depth n -> + Store.last_modified ?depth ?n t path >|= Result.ok); + io_field "lcas" + ~typ:(non_null (list (non_null (Lazy.force commit)))) + ~args:Arg.[ arg "commit" ~typ:(non_null Input.hash) ] + ~resolve:(fun _ (t, _) commit -> + Store.Commit.of_hash (Store.repo t) commit >>= function + | Some commit -> ( + Store.lcas_with_commit t commit >>= function + | Ok lcas -> Lwt.return (Ok lcas) + | Error e -> + let msg = Irmin.Type.to_string Store.lca_error_t e in + Lwt.return (Error msg)) + | None -> Lwt.return (Error "Commit not found")); + ])) + + and contents : + ('ctx, (Store.contents * Store.metadata * Store.path) option) Schema.typ + Lazy.t = + lazy + Schema.( + obj "Contents" ~fields:(fun _contents -> + [ + field "path" ~typ:(non_null Types.Path.schema_typ) ~args:[] + ~resolve:(fun _ (_, _, path) -> path); + field "metadata" ~typ:(non_null Types.Metadata.schema_typ) + ~args:[] ~resolve:(fun _ (_, metadata, _) -> metadata); + field "value" ~typ:(non_null Types.Contents.schema_typ) ~args:[] + ~resolve:(fun _ (contents, _, _) -> contents); + field "hash" ~typ:(non_null Types.Hash.schema_typ) ~args:[] + ~resolve:(fun _ (contents, _, _) -> + Store.Contents.hash contents); + ])) + + and contents_key_value : + ('ctx, (Store.contents_key * Store.metadata) option) Schema.typ Lazy.t = + lazy + Schema.( + obj "ContentsKey" ~fields:(fun _contents -> + [ + field "metadata" ~typ:(non_null Types.Metadata.schema_typ) + ~args:[] ~resolve:(fun _ (_, metadata) -> metadata); + field "contents" ~typ:(non_null Types.Contents_key.schema_typ) + ~args:[] ~resolve:(fun _ (key, _) -> key); + ])) + + and node_key_value : ('ctx, Store.node_key option) Schema.typ Lazy.t = + lazy + Schema.( + obj "NodeKey" ~fields:(fun _ -> + [ + field "node" ~typ:(non_null Types.Node_key.schema_typ) ~args:[] + ~resolve:(fun _ x -> x); + ])) + + and node = Schema.union "Node" + and tree_as_node = lazy (Schema.add_type node (Lazy.force tree)) + and contents_as_node = lazy (Schema.add_type node (Lazy.force contents)) + and kinded_key = Schema.union "KindedKey" + + and node_key_as_kinded_key = + lazy (Schema.add_type kinded_key (Lazy.force node_key_value)) + + and contents_key_as_kinded_key = + lazy (Schema.add_type kinded_key (Lazy.force contents_key_value)) + + [@@@ocaml.warning "-5"] + + let _ = Lazy.force tree_as_node + let _ = Lazy.force contents_as_node + let _ = Lazy.force node_key_as_kinded_key + let _ = Lazy.force contents_key_as_kinded_key + + let err_write e = + Lwt.return (Error (Irmin.Type.to_string Store.write_error_t e)) + + let remote s = + match Config.remote with + | Some _ -> + Schema. + [ + io_field "clone" + ~typ:Lazy.(force commit) + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "remote" ~typ:(non_null Input.remote); + ] + ~resolve:(fun _ _src branch remote -> + let* t = mk_branch s branch in + let* remote = remote in + Sync.fetch t remote >>= function + | Ok (`Head d) -> Store.Head.set t d >|= fun () -> Ok (Some d) + | Ok `Empty -> Lwt.return (Ok None) + | Error (`Msg e) -> Lwt.return (Error e)); + io_field "push" ~typ:(Lazy.force commit) + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "remote" ~typ:(non_null Input.remote); + arg "depth" ~typ:int; + ] + ~resolve:(fun _ _src branch remote depth -> + let* t = mk_branch s branch in + let* remote = remote in + Sync.push t ?depth remote >>= function + | Ok (`Head commit) -> Lwt.return (Ok (Some commit)) + | Ok `Empty -> Lwt.return (Ok None) + | Error e -> + let s = Fmt.to_to_string Sync.pp_push_error e in + Lwt.return (Error s)); + io_field "pull" ~typ:(Lazy.force commit) + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "remote" ~typ:(non_null Input.remote); + arg "info" ~typ:Input.info; + arg "depth" ~typ:int; + ] + ~resolve:(fun _ _src branch remote info depth -> + let* t = mk_branch s branch in + let strategy = + match info with + | Some info -> + let+ info, _, _, _ = txn_args s (Some info) in + `Merge info + | None -> Lwt.return `Set + in + let* remote = remote in + strategy >>= Sync.pull ?depth t remote >>= function + | Ok (`Head h) -> Lwt.return (Ok (Some h)) + | Ok `Empty -> Lwt.return (Ok None) + | Error (`Msg msg) -> Lwt.return (Error msg) + | Error (`Conflict msg) -> + Lwt.return (Error ("conflict: " ^ msg))); + ] + | None -> [] + + let to_tree tree l = + Lwt_list.fold_left_s + (fun tree -> function + | { path; value = Some v; metadata } -> + Store.Tree.add tree ?metadata path v + | { path; value = None; _ } -> Store.Tree.remove tree path) + tree l + + let mutations s = + Schema. + [ + io_field "set" ~typ:(Lazy.force commit) + ~doc:"Associate contents with the given path" + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "path" ~typ:(non_null Input.path); + arg "value" ~typ:(non_null Input.value); + arg "info" ~typ:Input.info; + ] + ~resolve:(fun _ _src branch k v i -> + let* t = mk_branch s branch in + let* info, retries, allow_empty, parents = txn_args s i in + Store.set t ?retries ?allow_empty ?parents k v ~info >>= function + | Ok () -> Store.Head.find t >|= Result.ok + | Error e -> err_write e); + io_field "set_tree" ~typ:(Lazy.force commit) + ~doc:"Set the tree at \"path\"" + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "path" ~typ:(non_null Input.path); + arg "tree" ~typ:(non_null Input.tree); + arg "info" ~typ:Input.info; + ] + ~resolve:(fun _ _src branch k items i -> + let* t = mk_branch s branch in + let* info, retries, allow_empty, parents = txn_args s i in + Lwt.catch + (fun () -> + let tree = Store.Tree.empty () in + let* tree = to_tree tree items in + Store.set_tree t ?retries ?allow_empty ?parents ~info k tree + >>= function + | Ok _ -> Store.Head.find t >|= Result.ok + | Error e -> err_write e) + (function Failure e -> Lwt.return (Error e) | e -> raise e)); + io_field "update_tree" ~typ:(Lazy.force commit) + ~doc:"Add/remove items from the tree specified by \"path\"" + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "path" ~typ:(non_null Input.path); + arg "tree" ~typ:(non_null Input.tree); + arg "info" ~typ:Input.info; + ] + ~resolve:(fun _ _src branch k items i -> + let* t = mk_branch s branch in + let* info, retries, allow_empty, parents = txn_args s i in + Lwt.catch + (fun () -> + Store.with_tree t ?retries ?allow_empty ?parents k ~info + (fun tree -> + let tree = + match tree with + | Some t -> t + | None -> Store.Tree.empty () + in + to_tree tree items >>= Lwt.return_some) + >>= function + | Ok _ -> Store.Head.find t >|= Result.ok + | Error e -> err_write e) + (function Failure e -> Lwt.return (Error e) | e -> raise e)); + io_field "set_all" ~typ:(Lazy.force commit) + ~doc:"Set contents and metadata" + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "path" ~typ:(non_null Input.path); + arg "value" ~typ:(non_null Input.value); + arg "metadata" ~typ:Input.metadata; + arg "info" ~typ:Input.info; + ] + ~resolve:(fun _ _src branch k v m i -> + let* t = mk_branch s branch in + let* info, retries, allow_empty, parents = txn_args s i in + let* tree = + Store.find_tree t k >>= function + | Some tree -> Lwt.return tree + | None -> Lwt.return (Store.Tree.empty ()) + in + let* tree = Store.Tree.add tree k ?metadata:m v in + Store.set_tree t ?retries ?allow_empty ?parents k tree ~info + >>= function + | Ok () -> Store.Head.find t >|= Result.ok + | Error e -> err_write e); + io_field "test_and_set" ~typ:(Lazy.force commit) + ~doc: + "Update a value with \"set\" argument if \"test\" matches the \ + current value" + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "path" ~typ:(non_null Input.path); + arg "test" ~typ:Input.value; + arg "set" ~typ:Input.value; + arg "info" ~typ:Input.info; + ] + ~resolve:(fun _ _src branch k test set i -> + let* t = mk_branch s branch in + let* info, retries, allow_empty, parents = txn_args s i in + Store.test_and_set ?retries ?allow_empty ?parents ~info t k ~test + ~set + >>= function + | Ok _ -> Store.Head.find t >|= Result.ok + | Error e -> err_write e); + io_field "test_and_set_branch" ~typ:(non_null bool) + ~doc: + "Update a branch with \"set\" argument if \"test\" matches the \ + current value" + ~args: + Arg. + [ + arg "branch" ~typ:(non_null Input.branch); + arg "test" ~typ:Input.commit_key; + arg "set" ~typ:Input.commit_key; + ] + ~resolve:(fun _ _src branch test set -> + let branches = Store.Backend.Repo.branch_t s in + Store.Backend.Branch.test_and_set branches branch ~test ~set + >|= Result.ok); + io_field "remove" ~typ:(Lazy.force commit) + ~doc:"Remove a path from the store" + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "path" ~typ:(non_null Input.path); + arg "info" ~typ:Input.info; + ] + ~resolve:(fun _ _src branch key i -> + let* t = mk_branch s branch in + let* info, retries, allow_empty, parents = txn_args s i in + Store.remove t ?retries ?allow_empty ?parents key ~info >>= function + | Ok () -> Store.Head.find t >|= Result.ok + | Error e -> err_write e); + io_field "merge" ~typ:Types.Hash.schema_typ + ~doc:"Merge the current value at the given path with another value" + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "path" ~typ:(non_null Input.path); + arg "value" ~typ:Input.value; + arg "old" ~typ:Input.value; + arg "info" ~typ:Input.info; + ] + ~resolve:(fun _ _src branch key value old info -> + let* t = mk_branch s branch in + let* info, retries, allow_empty, parents = txn_args s info in + Store.merge t key ~info ?retries ?allow_empty ?parents ~old value + >>= function + | Ok _ -> Store.hash t key >|= Result.ok + | Error e -> err_write e); + io_field "merge_tree" ~typ:(Lazy.force commit) + ~doc:"Merge a branch with a tree" + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "path" ~typ:(non_null Input.path); + arg "value" ~typ:Input.tree; + arg "old" ~typ:Input.tree; + arg "info" ~typ:Input.info; + ] + ~resolve:(fun _ _src branch key value old info -> + let* t = mk_branch s branch in + let* info, retries, allow_empty, parents = txn_args s info in + let* old = + match old with + | Some old -> + let tree = Store.Tree.empty () in + to_tree tree old >>= Lwt.return_some + | None -> Lwt.return_none + in + let* value = + match value with + | Some value -> + let tree = Store.Tree.empty () in + to_tree tree value >>= Lwt.return_some + | None -> Lwt.return_none + in + Store.merge_tree t key ~info ?retries ?allow_empty ?parents ~old + value + >>= function + | Ok _ -> Store.Head.find t >|= Result.ok + | Error e -> err_write e); + io_field "merge_with_branch" ~typ:(Lazy.force commit) + ~doc:"Merge a branch with another branch" + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "from" ~typ:(non_null Input.branch); + arg "info" ~typ:Input.info; + arg "max_depth" ~typ:int; + arg "n" ~typ:int; + ] + ~resolve:(fun _ _src into from i max_depth n -> + let* t = mk_branch s into in + let* info, _, _, _ = txn_args s i in + let* _ = Store.merge_with_branch t from ~info ?max_depth ?n in + Store.Head.find t >|= Result.ok); + io_field "merge_with_commit" + ~doc:"Merge a branch with a specific commit" ~typ:(Lazy.force commit) + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "from" ~typ:(non_null Input.hash); + arg "info" ~typ:Input.info; + arg "max_depth" ~typ:int; + arg "n" ~typ:int; + ] + ~resolve:(fun _ _src into from i max_depth n -> + let* t = mk_branch s into in + let* info, _, _, _ = txn_args s i in + Store.Commit.of_hash (Store.repo t) from >>= function + | Some from -> ( + Store.merge_with_commit t from ~info ?max_depth ?n >>= function + | Ok _ -> Store.Head.find t >|= Result.ok + | Error e -> + Lwt.return + (Error (Irmin.Type.to_string Irmin.Merge.conflict_t e))) + | None -> Lwt.return (Error "invalid hash")); + io_field "revert" ~doc:"Revert to a previous commit" + ~typ:(Lazy.force commit) + ~args: + Arg. + [ + arg "branch" ~typ:Input.branch; + arg "commit" ~typ:(non_null Input.hash); + ] + ~resolve:(fun _ _src branch commit -> + Store.Commit.of_hash s commit >>= function + | Some commit -> + let* t = mk_branch s branch in + Store.Head.set t commit >|= fun () -> Ok (Some commit) + | None -> Lwt.return (Ok None)); + ] + + let diff = + Schema.( + obj "Diff" ~fields:(fun _ -> + [ + field "commit" + ~typ:(non_null Lazy.(force commit)) + ~args:[] + ~resolve: + (fun _ctx -> function + | `Added c | `Removed c | `Updated (_, c) -> c); + ])) + + let map_diff diff ~added ~removed ~updated = + match diff with + | `Added x -> `Added (added x) + | `Removed x -> `Removed (removed x) + | `Updated (x, y) -> `Updated (updated x y) + + let subscriptions s = + Schema. + [ + subscription_field "watch" ~typ:(non_null diff) + ~doc:"Watch for changes to a branch" + ~args: + Arg.[ arg "branch" ~typ:Input.branch; arg "path" ~typ:Input.path ] + ~resolve:(fun _ctx branch path -> + let* t = mk_branch s branch in + let stream, push = Lwt_stream.create () in + let destroy_stream watch () = + push None; + Lwt.ignore_result (Store.unwatch watch) + in + match path with + | None -> + let+ watch = + Store.watch t (fun diff -> + push (Some diff); + Lwt.return_unit) + in + Ok (stream, destroy_stream watch) + | Some path -> + let+ watch = + Store.watch_key t path (function diff -> + push + (Some + (map_diff diff + ~added:(fun (c, _) -> c) + ~removed:(fun (c, _) -> c) + ~updated:(fun (before, _) (after, _) -> + (before, after)))); + Lwt.return_unit) + in + Ok (stream, destroy_stream watch)); + ] + + let schema s = + let mutations = mutations s @ remote s in + let subscriptions = subscriptions s in + Schema.( + schema ~mutations ~subscriptions + [ + io_field "commit" ~doc:"Find commit by hash" ~typ:(Lazy.force commit) + ~args:Arg.[ arg "hash" ~typ:(non_null Input.hash) ] + ~resolve:(fun _ _src hash -> + Store.Commit.of_hash s hash >|= Result.ok); + io_field "contents" ~doc:"Find contents by hash" + ~typ:Types.Contents.schema_typ + ~args:Arg.[ arg "hash" ~typ:(non_null Input.hash) ] + ~resolve:(fun _ _src k -> Store.Contents.of_hash s k >|= Result.ok); + io_field "commit_of_key" ~doc:"Find commit by key" + ~typ:(Lazy.force commit) + ~args:Arg.[ arg "key" ~typ:(non_null Input.commit_key) ] + ~resolve:(fun _ _src k -> Store.Commit.of_key s k >|= Result.ok); + io_field "contents_of_key" ~doc:"Find contents by key" + ~typ:Types.Contents.schema_typ + ~args:Arg.[ arg "key" ~typ:(non_null Input.contents_key) ] + ~resolve:(fun _ _src k -> Store.Contents.of_key s k >|= Result.ok); + io_field "branches" ~doc:"Get a list of all branches" + ~typ:(non_null (list (non_null Lazy.(force branch)))) + ~args:[] + ~resolve:(fun _ _ -> + Store.Branch.list s + >>= Lwt_list.map_p (fun branch -> + let+ store = Store.of_branch s branch in + (store, branch)) + >|= Result.ok); + io_field "main" ~doc:"Get main branch" ~typ:(Lazy.force branch) + ~args:[] ~resolve:(fun _ _ -> + let+ t = Store.main s in + Ok (Some (t, Store.Branch.main))); + io_field "branch" ~doc:"Get branch by name" ~typ:(Lazy.force branch) + ~args:Arg.[ arg "name" ~typ:(non_null Input.branch) ] + ~resolve:(fun _ _ branch -> + let+ t = Store.of_branch s branch in + Ok (Some (t, branch))); + ]) + + let execute_request ctx req = Graphql_server.execute_request ctx () req + + let v store = + let schema = schema store in + let callback = Graphql_server.make_callback (fun _ctx -> ()) schema in + Server.make_response_action ~callback () +end + +module Make + (Server : Cohttp_lwt.S.Server) + (Config : CONFIG) + (Store : Irmin.Generic_key.S with type Schema.Info.t = Config.info) = +struct + module Types = Default_types (Store) + include Make_ext (Server) (Config) (Store) (Types) +end diff --git a/vendors/irmin/src/irmin-graphql/server.mli b/vendors/irmin/src/irmin-graphql/server.mli new file mode 100644 index 0000000000000000000000000000000000000000..ff31f7167201510a72e6acc6080c82b175b22b8d --- /dev/null +++ b/vendors/irmin/src/irmin-graphql/server.mli @@ -0,0 +1,113 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Schema = Graphql_lwt.Schema + +(** GraphQL server *) +module type S = sig + module IO : Cohttp_lwt.S.IO + + type repo + type server + + type response_action = + [ `Expert of Cohttp.Response.t * (IO.ic -> IO.oc -> unit Lwt.t) + | `Response of Cohttp.Response.t * Cohttp_lwt.Body.t ] + + val schema : repo -> unit Schema.schema + + val execute_request : + unit Schema.schema -> + Cohttp_lwt.Request.t -> + Cohttp_lwt.Body.t -> + response_action Lwt.t + + val v : repo -> server +end + +(** GraphQL server config *) +module type CONFIG = sig + type info + + val remote : (?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t) option + + val info : + ?author:string -> ('a, Format.formatter, unit, unit -> info) format4 -> 'a +end + +(** Custom GraphQL schema type and argument type for [type t]. *) +module type CUSTOM_TYPE = sig + type t + + val schema_typ : (unit, t option) Schema.typ + val arg_typ : t option Schema.Arg.arg_typ +end + +(** GraphQL types for Irmin concepts (key, metadata, contents, hash and branch). *) +module type CUSTOM_TYPES = sig + type path + type metadata + type contents + type hash + type branch + type commit_key + type contents_key + type node_key + + module Path : CUSTOM_TYPE with type t := path + module Metadata : CUSTOM_TYPE with type t := metadata + module Contents : CUSTOM_TYPE with type t := contents + module Hash : CUSTOM_TYPE with type t := hash + module Branch : CUSTOM_TYPE with type t := branch + module Commit_key : CUSTOM_TYPE with type t := commit_key + module Contents_key : CUSTOM_TYPE with type t := contents_key + module Node_key : CUSTOM_TYPE with type t := node_key +end + +(** Default GraphQL types for the Irmin store [S]. *) +module Default_types (S : Irmin.Generic_key.S) : + CUSTOM_TYPES + with type path := S.path + and type metadata := S.metadata + and type contents := S.contents + and type hash := S.hash + and type branch := S.branch + and type commit_key := S.commit_key + and type contents_key := S.contents_key + and type node_key := S.node_key + +(** Create a GraphQL server with default GraphQL types for [S]. *) +module Make + (Server : Cohttp_lwt.S.Server) + (Config : CONFIG) + (Store : Irmin.Generic_key.S with type Schema.Info.t = Config.info) : + S with type repo = Store.repo and type server = Server.t + +(** Create a GraphQL server with custom GraphQL types. *) +module Make_ext + (Server : Cohttp_lwt.S.Server) + (Config : CONFIG) + (Store : Irmin.Generic_key.S with type Schema.Info.t = Config.info) + (Types : CUSTOM_TYPES + with type path := Store.path + and type metadata := Store.metadata + and type contents := Store.contents + and type hash := Store.hash + and type branch := Store.branch + and type commit_key := Store.commit_key + and type contents_key := Store.contents_key + and type node_key := Store.node_key) : + S with type repo = Store.repo and type server = Server.t diff --git a/vendors/irmin/src/irmin-graphql/unix/dune b/vendors/irmin/src/irmin-graphql/unix/dune new file mode 100644 index 0000000000000000000000000000000000000000..694d4afc35653fe5de690f9ca2b30d1db1a37627 --- /dev/null +++ b/vendors/irmin/src/irmin-graphql/unix/dune @@ -0,0 +1,8 @@ +(library + (public_name irmin-graphql.unix) + (name irmin_graphql_unix) + (libraries cohttp-lwt-unix irmin-graphql irmin.unix git-unix lwt.unix) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-graphql/unix/irmin_graphql_unix.ml b/vendors/irmin/src/irmin-graphql/unix/irmin_graphql_unix.ml new file mode 100644 index 0000000000000000000000000000000000000000..b7e4d46c23f62866efcf836f21041e90e6010e34 --- /dev/null +++ b/vendors/irmin/src/irmin-graphql/unix/irmin_graphql_unix.ml @@ -0,0 +1,76 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type remote_fn = + ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t + +module Server = struct + module Remote = struct + module None = struct + let remote = None + end + end + + module Make_ext + (S : Irmin.Generic_key.S) (Remote : sig + val remote : remote_fn option + end) + (T : Irmin_graphql.Server.CUSTOM_TYPES + with type path := S.path + and type metadata := S.metadata + and type contents := S.contents + and type hash := S.hash + and type branch := S.branch + and type commit_key := S.commit_key + and type contents_key := S.contents_key + and type node_key := S.node_key) = + Irmin_graphql.Server.Make_ext + (Cohttp_lwt_unix.Server) + (struct + module Info = Irmin_unix.Info (S.Info) + + type info = S.info + + let info = Info.v + + let remote = + match Remote.remote with + | Some fn -> Some (fun ?headers v -> fn ?headers v) + | None -> None + end) + (S) + (T) + + module Make + (S : Irmin.Generic_key.S) (Remote : sig + val remote : remote_fn option + end) = + Irmin_graphql.Server.Make + (Cohttp_lwt_unix.Server) + (struct + module Info = Irmin_unix.Info (S.Info) + + type info = S.info + + let info = Info.v + + let remote = + match Remote.remote with + | Some fn -> Some (fun ?headers v -> fn ?headers v) + | None -> None + end) + (S) +end diff --git a/vendors/irmin/src/irmin-graphql/unix/irmin_graphql_unix.mli b/vendors/irmin/src/irmin-graphql/unix/irmin_graphql_unix.mli new file mode 100644 index 0000000000000000000000000000000000000000..37da0f34f9e49cab5f399d92b6aa54b39f5bd03b --- /dev/null +++ b/vendors/irmin/src/irmin-graphql/unix/irmin_graphql_unix.mli @@ -0,0 +1,51 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type remote_fn = + ?ctx:Mimic.ctx -> ?headers:Cohttp.Header.t -> string -> Irmin.remote Lwt.t + +module Server : sig + module Remote : sig + module None : sig + val remote : remote_fn option + end + end + + module Make + (S : Irmin.Generic_key.S) (Remote : sig + val remote : remote_fn option + end) : + Irmin_graphql.Server.S + with type repo = S.repo + and type server = Cohttp_lwt_unix.Server.t + + module Make_ext + (S : Irmin.Generic_key.S) (Remote : sig + val remote : remote_fn option + end) + (T : Irmin_graphql.Server.CUSTOM_TYPES + with type path := S.path + and type metadata := S.metadata + and type contents := S.contents + and type hash := S.hash + and type branch := S.branch + and type commit_key := S.commit_key + and type contents_key := S.contents_key + and type node_key := S.node_key) : + Irmin_graphql.Server.S + with type repo = S.repo + and type server = Cohttp_lwt_unix.Server.t +end diff --git a/vendors/irmin/src/irmin-http/closeable.ml b/vendors/irmin/src/irmin-http/closeable.ml new file mode 100644 index 0000000000000000000000000000000000000000..9e38a7ffbb0f57c87c8618a93624bc4bf94de3fb --- /dev/null +++ b/vendors/irmin/src/irmin-http/closeable.ml @@ -0,0 +1,118 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open S + +module Content_addressable (S : Content_addressable.S) = struct + type 'a t = { closed : bool ref; t : 'a S.t } + type key = S.key + type value = S.value + type ctx = S.ctx + + let check_not_closed t = if !(t.closed) then raise Irmin.Closed + + let mem t k = + check_not_closed t; + S.mem t.t k + + let find t k = + check_not_closed t; + S.find t.t k + + let add t v = + check_not_closed t; + S.add t.t v + + let unsafe_add t k v = + check_not_closed t; + S.unsafe_add t.t k v + + let v ?ctx uri item items = + let+ t = S.v ?ctx uri item items in + { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) + + let batch t f = + check_not_closed t; + S.batch t.t (fun w -> f { t = w; closed = t.closed }) +end + +module Atomic_write (S : Atomic_write.S) = struct + type t = { closed : bool ref; t : S.t } + type key = S.key + type value = S.value + type ctx = S.ctx + + let check_not_closed t = if !(t.closed) then raise Irmin.Closed + + let mem t k = + check_not_closed t; + S.mem t.t k + + let find t k = + check_not_closed t; + S.find t.t k + + let set t k v = + check_not_closed t; + S.set t.t k v + + let test_and_set t k ~test ~set = + check_not_closed t; + S.test_and_set t.t k ~test ~set + + let remove t k = + check_not_closed t; + S.remove t.t k + + let list t = + check_not_closed t; + S.list t.t + + type watch = S.watch + + let watch t ?init f = + check_not_closed t; + S.watch t.t ?init f + + let watch_key t k ?init f = + check_not_closed t; + S.watch_key t.t k ?init f + + let unwatch t w = + check_not_closed t; + S.unwatch t.t w + + let v ?ctx uri item items = + let+ t = S.v ?ctx uri item items in + { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) + + let clear t = + check_not_closed t; + S.clear t.t +end diff --git a/vendors/irmin/src/irmin-http/closeable.mli b/vendors/irmin/src/irmin-http/closeable.mli new file mode 100644 index 0000000000000000000000000000000000000000..965927b9db2631ffa9438d2cafcec413b05a4ab8 --- /dev/null +++ b/vendors/irmin/src/irmin-http/closeable.mli @@ -0,0 +1,32 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Augments primitive store modules with close semantics *) + +open S + +module Content_addressable (M : Content_addressable.S) : + Content_addressable.S + with type key = M.key + and type value = M.value + and type ctx = M.ctx + +module Atomic_write (M : Atomic_write.S) : + Atomic_write.S + with type key = M.key + and type value = M.value + and type watch = M.watch + and type ctx = M.ctx diff --git a/vendors/irmin/src/irmin-http/common.ml b/vendors/irmin/src/irmin-http/common.ml new file mode 100644 index 0000000000000000000000000000000000000000..6ce4b62db1e760f7785fd9c135b83ee5d05c6564 --- /dev/null +++ b/vendors/irmin/src/irmin-http/common.ml @@ -0,0 +1,29 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let irmin_version = "X-IrminVersion" + +type status = { status : string } [@@deriving irmin] + +type 'a set = { test : 'a option; set : 'a option; v : 'a option } +[@@deriving irmin] + +type ('a, 'b) event = { branch : 'a; diff : 'b Irmin.Diff.t } [@@deriving irmin] +type ('a, 'b) init = { branch : 'a; commit : 'b } [@@deriving irmin] +type 'a merge = { old : 'a; left : 'a; right : 'a } [@@deriving irmin] + +type 'a merge_result = ('a option, Irmin.Merge.conflict) result +[@@deriving irmin] diff --git a/vendors/irmin/src/irmin-http/dune b/vendors/irmin/src/irmin-http/dune new file mode 100644 index 0000000000000000000000000000000000000000..a3dc1b3ad467e3386994b00b74df93de6d44704f --- /dev/null +++ b/vendors/irmin/src/irmin-http/dune @@ -0,0 +1,19 @@ +(library + (name irmin_http) + (public_name irmin-http) + (libraries + astring + cohttp + cohttp-lwt + fmt + irmin + jsonm + logs + lwt + uri + unix + webmachine) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-http/import.ml b/vendors/irmin/src/irmin-http/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..71053e21ba54118af9da1fc7b37d45eb620c46e2 --- /dev/null +++ b/vendors/irmin/src/irmin-http/import.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/src/irmin-http/irmin_http.ml b/vendors/irmin/src/irmin-http/irmin_http.ml new file mode 100644 index 0000000000000000000000000000000000000000..0191c7c60751c250c90d4361d59837c6e455cd74 --- /dev/null +++ b/vendors/irmin/src/irmin-http/irmin_http.ml @@ -0,0 +1,566 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Common +open Astring +open! Import + +let src = Logs.Src.create "irmin.http" ~doc:"Irmin HTTP REST interface" + +module Log = (val Logs.src_log src : Logs.LOG) +module T = Irmin.Type + +module Conf = struct + include Irmin.Backend.Conf + + let spec = Spec.v "http" + + module Key = struct + (* ~uri *) + let uri = + key ~spec ~docv:"URI" ~docs:"COMMON OPTIONS" + ~doc:"Location of the remote store." "uri" + Irmin.Type.(option uri) + None + end +end + +let config x config = + let a = Conf.empty Conf.spec in + Conf.(verify (union (add a Key.uri (Some x)) config)) + +let uri_append t path = + match Uri.path t :: path with + | [] -> t + | path -> + let buf = Buffer.create 10 in + List.iter + (function + | "" -> () + | s -> + if s.[0] <> '/' then Buffer.add_char buf '/'; + Buffer.add_string buf s) + path; + let path = Buffer.contents buf in + Uri.with_path t path + +let err_no_uri () = invalid_arg "Irmin_http.create: No URI specified" + +let get_uri config = + match Conf.(get config Key.uri) with None -> err_no_uri () | Some u -> u + +let invalid_arg fmt = Fmt.kstr Lwt.fail_invalid_arg fmt + +exception Escape of ((int * int) * (int * int)) * Jsonm.error + +let () = + Printexc.register_printer (function + | Escape ((start, end_), err) -> + Fmt.kstr + (fun s -> Some s) + "Escape ({ start = %a; end = %a; error = %a })" + Fmt.(Dump.pair int int) + start + Fmt.(Dump.pair int int) + end_ Jsonm.pp_error err + | _ -> None) + +let json_stream (stream : string Lwt_stream.t) : Jsonm.lexeme list Lwt_stream.t + = + let d = Jsonm.decoder `Manual in + let rec lexeme () = + match Jsonm.decode d with + | `Lexeme l -> Lwt.return l + | `Error e -> Lwt.fail (Escape (Jsonm.decoded_range d, e)) + | `End -> assert false + | `Await -> ( + Lwt_stream.get stream >>= function + | None -> Lwt.fail (Escape (Jsonm.decoded_range d, `Expected `Value)) + | Some str -> + Jsonm.Manual.src d (Bytes.of_string str) 0 (String.length str); + lexeme ()) + in + let lexemes e = + let lexemes = ref [] in + let objs = ref 0 in + let arrs = ref 0 in + let rec aux () = + let* l = lexeme e in + lexemes := l :: !lexemes; + let () = + match l with + | `Os -> incr objs + | `As -> incr arrs + | `Oe -> decr objs + | `Ae -> decr arrs + | `Name _ | `Null | `Bool _ | `String _ | `Float _ -> () + in + if !objs > 0 || !arrs > 0 then aux () else Lwt.return_unit + in + let+ () = aux () in + List.rev !lexemes + in + let open_stream () = + lexeme () >>= function + | `As -> Lwt.return_unit + | _ -> Lwt.fail (Escape (Jsonm.decoded_range d, `Expected (`Aval true))) + in + let opened = ref false in + let open_and_get () = + if not !opened then ( + open_stream () >>= fun () -> + opened := true; + lexemes () >|= Option.some) + else lexemes () >|= Option.some + in + Lwt_stream.from open_and_get + +let of_json = Irmin.Type.of_json_string +let to_json = Irmin.Type.to_json_string + +module Helper (Client : Cohttp_lwt.S.Client) : + S.Helper with type ctx = Client.ctx = struct + type ctx = Client.ctx + + let err_bad_version v = + invalid_arg "bad server version: expecting %s, but got %s" Irmin.version + (match v with None -> "" | Some v -> v) + + let check_version r = + match Cohttp.Header.get (Cohttp.Response.headers r) irmin_version with + | None -> err_bad_version None + | Some v -> + if v <> Irmin.version then err_bad_version (Some v) else Lwt.return_unit + + let is_success r = + match Cohttp.Response.status r with `OK -> true | _ -> false + + let map_string_response parse (r, b) = + check_version r >>= fun () -> + let* b = Cohttp_lwt.Body.to_string b in + if is_success r then + match parse b with + | Ok x -> Lwt.return x + | Error (`Msg e) -> + Lwt.fail_with (Fmt.str "Error while parsing %S: %s" b e) + else Lwt.fail_with ("Server error: " ^ b) + + let map_stream_response t (r, b) = + check_version r >>= fun () -> + if not (is_success r) then + let* b = Cohttp_lwt.Body.to_string b in + Lwt.fail_with ("Server error: " ^ b) + else + let stream = Cohttp_lwt.Body.to_stream b in + let stream = json_stream stream in + let stream = + let aux j = + match T.decode_json_lexemes t j with + | Error (`Msg e) -> Lwt.fail_with e + | Ok c -> Lwt.return c + in + Lwt_stream.map_s aux stream + in + Lwt.return stream + + let headers ~keep_alive () = + let keep_alive = + if keep_alive then [ ("Connection", "Keep-Alive") ] else [] + in + Cohttp.Header.of_list + ([ (irmin_version, Irmin.version); ("Content-type", "application/json") ] + @ keep_alive) + + let map_call meth t ctx ~keep_alive ?body path fn = + let uri = uri_append t path in + let body = match body with None -> None | Some b -> Some (`String b) in + let headers = headers ~keep_alive () in + [%log.debug "%s %s" (Cohttp.Code.string_of_method meth) (Uri.path uri)]; + Lwt.catch + (fun () -> Client.call ?ctx meth ~headers ?body uri >>= fn) + (fun e -> + [%log.debug "request to %a failed: %a" Uri.pp_hum uri Fmt.exn e]; + Lwt.fail e) + + let call meth t ctx ?body path parse = + map_call meth t ctx ~keep_alive:false ?body path (map_string_response parse) + + let call_stream meth t ctx ?body path parse = + map_call meth t ctx ~keep_alive:true ?body path (map_stream_response parse) +end + +module RO (Client : Cohttp_lwt.S.Client) (K : Irmin.Type.S) (V : Irmin.Type.S) : + S.Read_only.S + with type ctx = Client.ctx + and type key = K.t + and type value = V.t = struct + type ctx = Client.ctx + + module HTTP = Helper (Client) + + type 'a t = { + uri : Uri.t; + item : string; + items : string; + ctx : Client.ctx option; + } + + let uri t = t.uri + let item t = t.item + let items t = t.items + let close _ = Lwt.return () + + type key = K.t + type value = V.t + + let key_str = Irmin.Type.to_string K.t + let val_of_str = Irmin.Type.of_string V.t + + let find t key = + HTTP.map_call `GET t.uri t.ctx ~keep_alive:false + [ t.item; key_str key ] + (fun ((r, _) as x) -> + if Cohttp.Response.status r = `Not_found then Lwt.return_none + else HTTP.map_string_response val_of_str x >|= Option.some) + + let mem t key = + HTTP.map_call `GET t.uri t.ctx ~keep_alive:false + [ t.item; key_str key ] + (fun (r, _) -> + if Cohttp.Response.status r = `Not_found then Lwt.return_false + else Lwt.return_true) + + let v ?ctx uri item items = Lwt.return { uri; item; items; ctx } +end + +module CA (Client : Cohttp_lwt.S.Client) (H : Irmin.Hash.S) (V : Irmin.Type.S) = +struct + include RO (Client) (H) (V) + + let add t value = + let body = Irmin.Type.to_string V.t value in + HTTP.call `POST t.uri t.ctx [ t.items ] ~body (Irmin.Type.of_string H.t) + + let unsafe_add t key value = + let body = Irmin.Type.to_string V.t value in + HTTP.call `POST t.uri t.ctx + [ "unsafe"; t.items; key_str key ] + ~body + Irmin.Type.(of_string unit) + + let cast t = (t :> read_write t) + + let batch t f = + (* TODO:cache the writes locally and send everything in one batch *) + f (cast t) + + let close _ = Lwt.return_unit +end + +module RW : S.Atomic_write.Maker = +functor + (Client : Cohttp_lwt.S.Client) + (K : Irmin.Type.S) + (V : Irmin.Type.S) + -> + struct + module RO = RO (Client) (K) (V) + module HTTP = RO.HTTP + module W = Irmin.Backend.Watch.Make (K) (V) + + type key = RO.key + type value = RO.value + type watch = W.watch + type ctx = Client.ctx + + (* cache the stream connections to the server: we open only one + connection per stream kind. *) + type cache = { mutable stop : unit -> unit } + + let empty_cache () = { stop = (fun () -> ()) } + + type t = { t : read RO.t; w : W.t; keys : cache; glob : cache } + + let get t = HTTP.call `GET (RO.uri t.t) t.t.ctx + let put t = HTTP.call `PUT (RO.uri t.t) t.t.ctx + let get_stream t = HTTP.call_stream `GET (RO.uri t.t) t.t.ctx + let post_stream t = HTTP.call_stream `POST (RO.uri t.t) t.t.ctx + + let v ?ctx uri item items = + let* t = RO.v ?ctx uri item items in + let w = W.v () in + let keys = empty_cache () in + let glob = empty_cache () in + Lwt.return { t; w; keys; glob } + + let find t = RO.find t.t + let mem t = RO.mem t.t + let key_str = Irmin.Type.to_string K.t + let list t = get t [ RO.items t.t ] (of_json T.(list K.t)) + + let set t key value = + let value = { v = Some value; set = None; test = None } in + let body = to_json (set_t V.t) value in + put t [ RO.item t.t; key_str key ] ~body (of_json status_t) >>= function + | { status = "ok" } -> Lwt.return_unit + | e -> Lwt.fail_with e.status + + let test_and_set t key ~test ~set = + let value = { v = None; set; test } in + let body = to_json (set_t V.t) value in + put t [ RO.item t.t; key_str key ] ~body (of_json status_t) >>= function + | { status = "true" } -> Lwt.return_true + | { status = "false" } -> Lwt.return_false + | e -> Lwt.fail_with e.status + + let pp_key = Irmin.Type.pp K.t + + let remove t key = + HTTP.map_call `DELETE (RO.uri t.t) t.t.ctx ~keep_alive:false + [ RO.item t.t; key_str key ] + (fun (r, b) -> + match Cohttp.Response.status r with + | `Not_found | `OK -> Lwt.return_unit + | _ -> + let* b = Cohttp_lwt.Body.to_string b in + Fmt.kstr Lwt.fail_with "cannot remove %a: %s" pp_key key b) + + let nb_keys t = fst (W.stats t.w) + let nb_glob t = snd (W.stats t.w) + + (* run [t] and returns an handler to stop the task. *) + let stoppable t = + let s, u = Lwt.task () in + Lwt.async (fun () -> Lwt.pick [ s; t () ]); + function () -> Lwt.wakeup u () + + let watch_key t key ?init f = + let key_str = Irmin.Type.to_string K.t key in + let init_stream () = + if nb_keys t <> 0 then Lwt.return_unit + else + let* s = + match init with + | None -> get_stream t [ "watch"; key_str ] (event_t K.t V.t) + | Some init -> + let body = to_json V.t init in + post_stream t [ "watch"; key_str ] ~body (event_t K.t V.t) + in + let stop () = + Lwt_stream.iter_s + (fun { diff; _ } -> + let diff = + match diff with + | `Removed _ -> None + | `Added v | `Updated (_, v) -> Some v + in + W.notify t.w key diff) + s + in + t.keys.stop <- stoppable stop; + Lwt.return_unit + in + let* () = init_stream () in + W.watch_key t.w key ?init f + + let watch t ?init f = + let init_stream () = + if nb_glob t <> 0 then Lwt.return_unit + else + let* s = + match init with + | None -> get_stream t [ "watches" ] (event_t K.t V.t) + | Some init -> + let init = + List.map (fun (branch, commit) -> { branch; commit }) init + in + let body = to_json T.(list (init_t K.t V.t)) init in + post_stream t [ "watches" ] ~body (event_t K.t V.t) + in + let stop () = + Lwt_stream.iter_s + (fun ev -> + let diff = + match ev.diff with + | `Removed _ -> None + | `Added v | `Updated (_, v) -> Some v + in + let k = ev.branch in + [%log.debug fun l -> + let pp_opt = + Fmt.option ~none:(Fmt.any "") (Irmin.Type.pp V.t) + in + l "notify %a: %a" pp_key k pp_opt diff] + ; + W.notify t.w k diff) + s + in + t.glob.stop <- stoppable stop; + Lwt.return_unit + in + let* () = init_stream () in + W.watch t.w ?init f + + let stop x = + let () = try x.stop () with _e -> () in + x.stop <- (fun () -> ()) + + let unwatch t id = + W.unwatch t.w id >>= fun () -> + if nb_keys t = 0 then stop t.keys; + if nb_glob t = 0 then stop t.glob; + Lwt.return_unit + + let close _ = Lwt.return_unit + + let clear t = + HTTP.call `POST t.t.uri t.t.ctx [ "clear"; t.t.items ] + Irmin.Type.(of_string unit) + end + +module type HTTP_CLIENT = sig + include Cohttp_lwt.S.Client + + val ctx : unit -> ctx option +end + +module Client (Client : HTTP_CLIENT) (S : Irmin.S) = struct + module X = struct + module Hash = S.Hash + module Schema = S.Schema + module Key = Irmin.Key.Of_hash (Hash) + + module Contents = struct + module X = struct + module Key = S.Hash + module Val = S.Contents + module CA = CA (Client) (Key) (Val) + include Closeable.Content_addressable (CA) + end + + include Irmin.Contents.Store (X) (X.Key) (X.Val) + + let v ?ctx config = X.v ?ctx config "blob" "blobs" + end + + module Node = struct + module Val = S.Backend.Node.Val + module Hash = Irmin.Hash.Typed (S.Hash) (Val) + module CA = CA (Client) (S.Hash) (Val) + include Irmin.Indexable.Of_content_addressable (S.Hash) (CA) + module Contents = Contents + module Metadata = S.Metadata + module Path = S.Path + + let merge (t : _ t) = + let f ~(old : Key.t option Irmin.Merge.promise) left right = + let* old = + old () >|= function + | Ok (Some old) -> old + | Ok None -> None + | Error _ -> None + in + let body = + Irmin.Type.(to_string (merge_t (option Key.t))) { old; left; right } + in + let result = merge_result_t Key.t in + CA.HTTP.call `POST t.uri t.ctx [ t.items; "merge" ] ~body + (Irmin.Type.of_string result) + in + Irmin.Merge.(v Irmin.Type.(option Key.t)) f + + let v ?ctx config = CA.v ?ctx config "tree" "trees" + end + + module Node_portable = Irmin.Node.Portable.Of_node (Node.Val) + + module Commit = struct + module X = struct + module Key = S.Hash + + module Val = struct + include S.Backend.Commit.Val + module Info = S.Info + + type hash = S.Hash.t [@@deriving irmin] + end + + module CA = CA (Client) (Key) (Val) + include Closeable.Content_addressable (CA) + end + + include Irmin.Commit.Store (S.Info) (Node) (X) (X.Key) (X.Val) + + let v ?ctx config = X.v ?ctx config "commit" "commits" + end + + module Commit_portable = Irmin.Commit.Portable.Of_commit (Commit.X.Val) + module Slice = Irmin.Backend.Slice.Make (Contents) (Node) (Commit) + module Remote = Irmin.Backend.Remote.None (Hash) (S.Branch) + + module Branch = struct + module Key = S.Branch + module Val = Commit.Key + include Closeable.Atomic_write (RW (Client) (Key) (S.Hash)) + + let v ?ctx config = v ?ctx config "branch" "branches" + end + + module Repo = struct + type t = { + config : Irmin.config; + contents : read Contents.t; + node : read Node.t; + commit : read Commit.t; + branch : Branch.t; + } + + let branch_t t = t.branch + let commit_t t = t.commit + let node_t t = t.node + let contents_t t = t.contents + let config t = t.config + + let batch t f = + Contents.X.batch t.contents @@ fun contents_t -> + Node.batch t.node @@ fun node_t -> + Commit.X.batch (snd t.commit) @@ fun commit_t -> + let commit_t = (node_t, commit_t) in + f contents_t node_t commit_t + + let v config = + let uri = get_uri config in + let ctx = Client.ctx () in + let* contents = Contents.v ?ctx uri in + let* node = Node.v ?ctx uri in + let* commit = Commit.v ?ctx uri in + let+ branch = Branch.v ?ctx uri in + let commit = (node, commit) in + { contents; node; commit; branch; config } + + let close t = + let* () = Contents.X.close t.contents in + let* () = Branch.close t.branch in + Commit.X.close (snd t.commit) + end + end + + include Irmin.Of_backend (X) +end + +module type SERVER = Irmin_http_server.S + +module Server = Irmin_http_server.Make diff --git a/vendors/irmin/src/irmin-http/irmin_http.mli b/vendors/irmin/src/irmin-http/irmin_http.mli new file mode 100644 index 0000000000000000000000000000000000000000..aa64b506faab3e5fb0714d97875ed34a0dce96ef --- /dev/null +++ b/vendors/irmin/src/irmin-http/irmin_http.mli @@ -0,0 +1,60 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** JSON REST/CRUD interface. *) + +val config : Uri.t -> Irmin.config -> Irmin.config + +module Conf : sig + open Irmin.Backend.Conf + + val spec : Spec.t + + module Key : sig + val uri : Uri.t option key + end +end + +module type HTTP_CLIENT = sig + include Cohttp_lwt.S.Client + + val ctx : unit -> ctx option +end + +module Client (C : HTTP_CLIENT) (S : Irmin.S) : + Irmin.S + with type hash = S.hash + and module Schema = S.Schema + and type Backend.Remote.endpoint = unit + +(** HTTP server *) + +module type SERVER = sig + type repo + (** The type for Irmin repository. *) + + type t + (** The type for HTTP configuration. *) + + val v : ?strict:bool -> repo -> t + (** [v repo] returns the configuration for a server serving the contents of + [repo]. If [strict] is set, incoming connections will fail if they do not + have the right {i X-IrminVersion} headers. *) +end + +(** Create an HTTP server, serving the contents of an Irmin database. *) +module Server (HTTP : Cohttp_lwt.S.Server) (S : Irmin.S) : + SERVER with type repo = S.Repo.t and type t = HTTP.t diff --git a/vendors/irmin/src/irmin-http/irmin_http_server.ml b/vendors/irmin/src/irmin-http/irmin_http_server.ml new file mode 100644 index 0000000000000000000000000000000000000000..0e8e409227fbdce0918cac1d3c464a670904dbf9 --- /dev/null +++ b/vendors/irmin/src/irmin-http/irmin_http_server.ml @@ -0,0 +1,406 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common +module T = Irmin.Type + +let to_json = Irmin.Type.to_json_string +let of_json = Irmin.Type.of_json_string +let src = Logs.Src.create "irmin.http-srv" ~doc:"Irmin REST API server" + +module Log = (val Logs.src_log src : Logs.LOG) + +module type S = sig + type repo + type t + + val v : ?strict:bool -> repo -> t +end + +let ok = { status = "ok" } +let bool b = { status = string_of_bool b } + +module Make (HTTP : Cohttp_lwt.S.Server) (S : Irmin.S) = struct + module Wm = struct + module Rd = Webmachine.Rd + + module Clock = struct + let now () = int_of_float (Unix.gettimeofday ()) + end + + include Webmachine.Make (HTTP.IO) (Clock) + end + + module B = S.Backend + + class virtual resource = + object + inherit [Cohttp_lwt.Body.t] Wm.resource + + method! finish_request rd = + Wm.Rd.with_resp_headers + (fun h -> Cohttp.Header.add h irmin_version Irmin.version) + rd + |> Wm.continue () + end + + let parse_error rd str (`Msg e) = + let err = Fmt.str "Parse error %S: %s" str e in + Wm.respond ~body:(`String err) 400 rd + + module Content_addressable (S : sig + include Irmin.Content_addressable.S + + val batch : B.Repo.t -> (read_write t -> 'a Lwt.t) -> 'a Lwt.t + end) + (K : Irmin.Type.S with type t = S.key) + (V : Irmin.Type.S with type t = S.value) = + struct + let with_key rd f = + match Irmin.Type.of_string K.t (Wm.Rd.lookup_path_info_exn "id" rd) with + | Ok key -> f key + | Error _ -> Wm.respond 404 rd + + let add rd repo = + let* body = Cohttp_lwt.Body.to_string rd.Wm.Rd.req_body in + match Irmin.Type.of_string V.t body with + | Error e -> parse_error rd body e + | Ok body -> + S.batch repo @@ fun db -> + let* new_id = S.add db body in + let resp_body = `String (Irmin.Type.to_string K.t new_id) in + Wm.continue true { rd with Wm.Rd.resp_body } + + let unsafe_add rd repo key = + let* body = Cohttp_lwt.Body.to_string rd.Wm.Rd.req_body in + match Irmin.Type.of_string V.t body with + | Error e -> parse_error rd body e + | Ok body -> + S.batch repo @@ fun db -> + S.unsafe_add db key body >>= fun () -> + let resp_body = `String "" in + Wm.continue true { rd with Wm.Rd.resp_body } + + class items repo = + object + inherit resource + method! allowed_methods rd = Wm.continue [ `POST ] rd + + method content_types_provided rd = + Wm.continue [ ("application/json", fun _ -> assert false) ] rd + + method content_types_accepted rd = Wm.continue [] rd + method! process_post rd = add rd repo + end + + class unsafe_items repo = + object + inherit resource + method! allowed_methods rd = Wm.continue [ `POST ] rd + + method content_types_provided rd = + Wm.continue [ ("application/json", fun _ -> assert false) ] rd + + method content_types_accepted rd = Wm.continue [] rd + method! process_post rd = with_key rd (unsafe_add rd repo) + end + + class merge merge repo = + object + inherit resource + method! allowed_methods rd = Wm.continue [ `POST ] rd + + method content_types_provided rd = + Wm.continue [ ("application/json", fun _ -> assert false) ] rd + + method content_types_accepted rd = Wm.continue [] rd + + method! process_post rd = + let* body = Cohttp_lwt.Body.to_string rd.Wm.Rd.req_body in + match Irmin.Type.(of_string (merge_t (option K.t))) body with + | Error e -> parse_error rd body e + | Ok { old; left; right } -> + S.batch repo @@ fun db -> + let old = Irmin.Merge.promise old in + let* m = Irmin.Merge.f (merge db) ~old left right in + let result = merge_result_t K.t in + let resp_body = `String Irmin.(Type.to_string result m) in + Wm.continue true { rd with Wm.Rd.resp_body } + end + + class item db = + object (self) + inherit resource + + method private to_json rd = + with_key rd (fun key -> + let str = Irmin.Type.to_string V.t in + S.find db key >>= function + | Some value -> Wm.continue (`String (str value)) rd + | None -> Wm.respond 404 rd) + + method! allowed_methods rd = Wm.continue [ `GET; `HEAD ] rd + method content_types_accepted rd = Wm.continue [] rd + + method! resource_exists rd = + with_key rd (fun key -> + let* mem = S.mem db key in + Wm.continue mem rd) + + method content_types_provided rd = + Wm.continue [ ("application/json", self#to_json) ] rd + end + end + + module Atomic_write + (S : Irmin.Atomic_write.S) + (K : Irmin.Type.S with type t = S.key) + (V : Irmin.Type.S with type t = S.value) = + struct + class items db = + object (self) + inherit resource + method! allowed_methods rd = Wm.continue [ `GET; `HEAD ] rd + method content_types_accepted rd = Wm.continue [] rd + + method private to_json rd = + let* keys = S.list db in + let json = to_json T.(list K.t) keys in + Wm.continue (`String json) rd + + method content_types_provided rd = + Wm.continue [ ("application/json", self#to_json) ] rd + end + + let with_key rd f = + match Irmin.Type.of_string K.t rd.Wm.Rd.dispatch_path with + | Ok x -> f x + | Error _ -> Wm.respond 404 rd + + class item db = + object (self) + inherit resource + + method private of_json rd = + let* body = Cohttp_lwt.Body.to_string rd.Wm.Rd.req_body in + match of_json (set_t V.t) body with + | Error e -> parse_error rd body e + | Ok v -> + with_key rd (fun key -> + match v.v with + | Some v -> + S.set db key v >>= fun () -> + let resp_body = `String (to_json status_t ok) in + let rd = { rd with Wm.Rd.resp_body } in + Wm.continue true rd + | None -> + let* b = S.test_and_set db key ~test:v.test ~set:v.set in + let resp_body = `String (to_json status_t (bool b)) in + let rd = { rd with Wm.Rd.resp_body } in + Wm.continue b rd) + + method private to_json rd = + with_key rd (fun key -> + let str = Irmin.Type.to_string V.t in + S.find db key >>= function + | Some value -> Wm.continue (`String (str value)) rd + | None -> Wm.respond 404 rd) + + method! resource_exists rd = + with_key rd (fun key -> + let* mem = S.mem db key in + Wm.continue mem rd) + + method! allowed_methods rd = + Wm.continue [ `GET; `HEAD; `PUT; `DELETE ] rd + + method content_types_provided rd = + Wm.continue [ ("application/json", self#to_json) ] rd + + method content_types_accepted rd = + Wm.continue [ ("application/json", self#of_json) ] rd + + method! delete_resource rd = + with_key rd (fun key -> + S.remove db key >>= fun () -> + let resp_body = `String (to_json status_t ok) in + Wm.continue true { rd with Wm.Rd.resp_body }) + end + + class watches db = + object (self) + inherit resource + method! allowed_methods rd = Wm.continue [ `GET; `HEAD; `POST ] rd + method content_types_accepted rd = Wm.continue [] rd + + method private stream ?init () = + let stream, push = Lwt_stream.create () in + let init = + Option.map (List.map (fun i -> (i.branch, i.commit))) init + in + let+ w = + S.watch ?init db (fun branch diff -> + let v = to_json (event_t K.t V.t) { branch; diff } in + push (Some v); + push (Some ","); + Lwt.return_unit) + in + Lwt.async (fun () -> + Lwt_stream.closed stream >>= fun () -> S.unwatch db w); + push (Some "["); + `Stream stream + + method! process_post rd = + let* body = Cohttp_lwt.Body.to_string rd.Wm.Rd.req_body in + match of_json T.(list (init_t K.t V.t)) body with + | Error e -> parse_error rd body e + | Ok init -> + let* resp_body = self#stream ~init () in + Wm.continue true { rd with Wm.Rd.resp_body } + + method private of_json rd = + let* body = self#stream () in + Wm.continue body rd + + method content_types_provided rd = + Wm.continue [ ("application/json", self#of_json) ] rd + end + + class watch db = + object (self) + inherit resource + method! allowed_methods rd = Wm.continue [ `GET; `HEAD; `POST ] rd + method content_types_accepted rd = Wm.continue [] rd + + method private stream ?init key = + let stream, push = Lwt_stream.create () in + let+ w = + S.watch_key ?init db key (fun diff -> + let v = to_json (event_t K.t V.t) { branch = key; diff } in + push (Some v); + push (Some ","); + Lwt.return_unit) + in + Lwt.async (fun () -> + Lwt_stream.closed stream >>= fun () -> S.unwatch db w); + push (Some "["); + `Stream stream + + method! process_post rd = + let* body = Cohttp_lwt.Body.to_string rd.Wm.Rd.req_body in + match of_json V.t body with + | Error e -> parse_error rd body e + | Ok init -> + with_key rd (fun key -> + let* resp_body = self#stream ~init key in + Wm.continue true { rd with Wm.Rd.resp_body }) + + method private of_json rd = + with_key rd (fun key -> + let* body = self#stream key in + Wm.continue body rd) + + method content_types_provided rd = + Wm.continue [ ("application/json", self#of_json) ] rd + end + end + + module Blob = + Content_addressable + (struct + include B.Contents + + let unsafe_add t k v = unsafe_add t k v >|= fun _ -> () + let batch t f = B.Repo.batch t @@ fun x _ _ -> f x + end) + (B.Contents.Key) + (B.Contents.Val) + + module Tree = + Content_addressable + (struct + include B.Node + + let unsafe_add t k v = unsafe_add t k v >|= fun _ -> () + let batch t f = B.Repo.batch t @@ fun _ x _ -> f x + end) + (B.Node.Key) + (B.Node.Val) + + module Commit = + Content_addressable + (struct + include B.Commit + + let unsafe_add t k v = unsafe_add t k v >|= fun _ -> () + let batch t f = B.Repo.batch t @@ fun _ _ x -> f x + end) + (B.Commit.Key) + (B.Commit.Val) + + module Branch = Atomic_write (B.Branch) (B.Branch.Key) (B.Branch.Val) + + type repo = S.Repo.t + type t = HTTP.t + + let v ?strict:_ db = + let blob = B.Repo.contents_t db in + let tree = B.Repo.node_t db in + let commit = B.Repo.commit_t db in + let branch = B.Repo.branch_t db in + let routes = + [ + ("/blobs", fun () -> new Blob.items db); + ("/blob/:id", fun () -> new Blob.item blob); + ("/trees", fun () -> new Tree.items db); + ("/trees/merge", fun () -> new Tree.merge S.Backend.Node.merge db); + ("/tree/:id", fun () -> new Tree.item tree); + ("/commits", fun () -> new Commit.items db); + ("/commit/:id", fun () -> new Commit.item commit); + ("/unsafe/blobs/:id", fun () -> new Blob.unsafe_items db); + ("/unsafe/trees/:id", fun () -> new Tree.unsafe_items db); + ("/unsafe/commits/:id", fun () -> new Commit.unsafe_items db); + ("/branches", fun () -> new Branch.items branch); + ("/branch/*", fun () -> new Branch.item branch); + ("/watches", fun () -> new Branch.watches branch); + ("/watch/*", fun () -> new Branch.watch branch); + ] + in + let pp_con = Fmt.of_to_string Cohttp.Connection.to_string in + let callback (_ch, conn) request body = + let open Cohttp in + [%log.debug "new connection %a" pp_con conn]; + let* status, headers, body, _path = + Wm.dispatch' routes ~body ~request >|= function + | None -> (`Not_found, Header.init (), `String "Not found", []) + | Some result -> result + in + [%log.info + "[%a] %d - %s %s" pp_con conn + (Code.code_of_status status) + (Code.string_of_method (Request.meth request)) + (Uri.path (Request.uri request))]; + + (* Finally, send the response to the client *) + HTTP.respond ~headers ~body ~status () + in + (* create the server and handle requests with the function defined above *) + let conn_closed (_, conn) = + [%log.debug "connection %a closed" pp_con conn] + in + HTTP.make ~callback ~conn_closed () +end diff --git a/vendors/irmin/src/irmin-http/irmin_http_server.mli b/vendors/irmin/src/irmin-http/irmin_http_server.mli new file mode 100644 index 0000000000000000000000000000000000000000..9e78f77f0a3dbbaa7f1a066f961b0673135c3af8 --- /dev/null +++ b/vendors/irmin/src/irmin-http/irmin_http_server.mli @@ -0,0 +1,34 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** HTTP server *) + +module type S = sig + type repo + (** The type for Irmin repository. *) + + type t + (** The type for HTTP configuration. *) + + val v : ?strict:bool -> repo -> t + (** [v repo] returns the configuration for a server serving the contents of + [repo]. If [strict] is set, incoming connections will fail if they do not + have the right {i X-IrminVersion} headers. *) +end + +(** Create an HTTP server, serving the contents of an Irmin database. *) +module Make (HTTP : Cohttp_lwt.S.Server) (S : Irmin.S) : + S with type repo = S.Repo.t and type t = HTTP.t diff --git a/vendors/irmin/src/irmin-http/s.ml b/vendors/irmin/src/irmin-http/s.ml new file mode 100644 index 0000000000000000000000000000000000000000..31c6aa6c029eda7a96bbd58dbd0dfac2635341d3 --- /dev/null +++ b/vendors/irmin/src/irmin-http/s.ml @@ -0,0 +1,124 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module T = Irmin.Type + +module type Helper = sig + type ctx + + val err_bad_version : string option -> 'a Lwt.t + val check_version : Cohttp.Response.t -> unit Lwt.t + val is_success : Cohttp.Response.t -> bool + + val map_string_response : + (string -> ('a, [< `Msg of string ]) result) -> + Cohttp.Response.t * Cohttp_lwt.Body.t -> + 'a Lwt.t + + val map_stream_response : + 'a T.t -> Cohttp.Response.t * Cohttp_lwt.Body.t -> 'a Lwt_stream.t Lwt.t + + val headers : keep_alive:bool -> unit -> Cohttp.Header.t + + val map_call : + Cohttp.Code.meth -> + Uri.t -> + ctx option -> + keep_alive:bool -> + ?body:string -> + string list -> + (Cohttp.Response.t * Cohttp_lwt.Body.t -> 'a Lwt.t) -> + 'a Lwt.t + + val call : + Cohttp.Code.meth -> + Uri.t -> + ctx option -> + ?body:string -> + string list -> + (string -> ('a, [< `Msg of string ]) result) -> + 'a Lwt.t + + val call_stream : + Cohttp.Code.meth -> + Uri.t -> + ctx option -> + ?body:string -> + string list -> + 'a T.t -> + 'a Lwt_stream.t Lwt.t +end + +module Read_only = struct + module type S = sig + type ctx + + type -'a t = { + uri : Uri.t; + item : string; + items : string; + ctx : ctx option; + } + + include Irmin.Read_only.S with type 'a t := 'a t + module HTTP : Helper with type ctx = ctx + + val uri : 'a t -> Uri.t + val item : 'a t -> string + val items : 'a t -> string + val key_str : key -> string + val val_of_str : value T.of_string + val v : ?ctx:ctx -> Uri.t -> string -> string -> 'a t Lwt.t + end +end + +module Content_addressable = struct + module type S = sig + include Irmin.Content_addressable.S + + type ctx + + val v : ?ctx:ctx -> Uri.t -> string -> string -> 'a t Lwt.t + end + + module type Maker = functor + (Client : Cohttp_lwt.S.Client) + (H : Irmin.Hash.S) + (V : Irmin.Type.S) + -> S with type key = H.t and type value = V.t and type ctx = Client.ctx +end + +module Atomic_write = struct + module type S = sig + include Irmin.Atomic_write.S + + type ctx + + val v : ?ctx:ctx -> Uri.t -> string -> string -> t Lwt.t + end + + module type Maker = functor + (Client : Cohttp_lwt.S.Client) + (B : Irmin.Branch.S) + (H : Irmin.Hash.S) + -> sig + module W : Irmin.Backend.Watch.S with type key = B.t and type value = H.t + module RO : Read_only.S + module HTTP = RO.HTTP + include S with type key = B.t and type value = H.t and type ctx = Client.ctx + end +end diff --git a/vendors/irmin/src/irmin-http/unix/dune b/vendors/irmin/src/irmin-http/unix/dune new file mode 100644 index 0000000000000000000000000000000000000000..1b0a23456c2bd2a38d95aa71c56b07d31c7f73dd --- /dev/null +++ b/vendors/irmin/src/irmin-http/unix/dune @@ -0,0 +1,8 @@ +(library + (public_name irmin-http.unix) + (name irmin_http_unix) + (libraries cohttp-lwt-unix irmin-http lwt.unix) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-http/unix/irmin_http_unix.ml b/vendors/irmin/src/irmin-http/unix/irmin_http_unix.ml new file mode 100644 index 0000000000000000000000000000000000000000..159cf80e80a3d4d11e77340651cc169eacf5ac7f --- /dev/null +++ b/vendors/irmin/src/irmin-http/unix/irmin_http_unix.ml @@ -0,0 +1,44 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type Sock = sig + val sock : string +end + +module DefaultSock = struct + let sock = "/var/run/irmin.sock" +end + +module type Http_client = sig + include module type of Cohttp_lwt_unix.Client + + val ctx : unit -> ctx option +end + +module Http_client (P : Sock) = struct + include Cohttp_lwt_unix.Client + + let ctx () = + let resolver = + let h = Hashtbl.create 1 in + Hashtbl.add h "irmin" (`Unix_domain_socket P.sock); + Resolver_lwt_unix.static h + in + Some (Cohttp_lwt_unix.Client.custom_ctx ~resolver ()) +end + +module Client = Irmin_http.Client (Http_client (DefaultSock)) +module Server = Irmin_http.Server (Cohttp_lwt_unix.Server) diff --git a/vendors/irmin/src/irmin-http/unix/irmin_http_unix.mli b/vendors/irmin/src/irmin-http/unix/irmin_http_unix.mli new file mode 100644 index 0000000000000000000000000000000000000000..2213e35c6ff4a19d76012a93da79f9a422f64502 --- /dev/null +++ b/vendors/irmin/src/irmin-http/unix/irmin_http_unix.mli @@ -0,0 +1,38 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type Sock = sig + val sock : string +end + +module type Http_client = sig + include module type of Cohttp_lwt_unix.Client + + val ctx : unit -> ctx option +end + +module Http_client (P : Sock) : Http_client + +module Client (S : Irmin.S) : + Irmin.S + with type hash = S.Hash.t + and module Schema = S.Schema + and type Backend.Remote.endpoint = unit + +module Server (S : Irmin.S) : + Irmin_http.SERVER + with type repo = S.Repo.t + and type t = Cohttp_lwt_unix.Server.t diff --git a/vendors/irmin/src/irmin-mirage/dune b/vendors/irmin/src/irmin-mirage/dune new file mode 100644 index 0000000000000000000000000000000000000000..a369cdfe7dc29a2f5995296bd3d01ce17f9bd449 --- /dev/null +++ b/vendors/irmin/src/irmin-mirage/dune @@ -0,0 +1,6 @@ +(library + (name irmin_mirage) + (public_name irmin-mirage) + (libraries fmt irmin irmin.mem mirage-clock ptime) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-mirage/git/dune b/vendors/irmin/src/irmin-mirage/git/dune new file mode 100644 index 0000000000000000000000000000000000000000..9d31cb910ee5c5b243ace2b8cea54d10acee8b9a --- /dev/null +++ b/vendors/irmin/src/irmin-mirage/git/dune @@ -0,0 +1,15 @@ +(library + (name irmin_mirage_git) + (public_name irmin-mirage-git) + (libraries + fmt + git + irmin + irmin-mirage + irmin-git + lwt + mirage-clock + mirage-kv + uri) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-mirage/git/irmin_mirage_git.ml b/vendors/irmin/src/irmin-mirage/git/irmin_mirage_git.ml new file mode 100644 index 0000000000000000000000000000000000000000..141b0d90d66ddc1afbb81694d76a60dd4668471a --- /dev/null +++ b/vendors/irmin/src/irmin-mirage/git/irmin_mirage_git.ml @@ -0,0 +1,355 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt.Infix +include Irmin_mirage_git_intf + +let remote ?(ctx = Mimic.empty) ?headers uri = + let ( ! ) f a b = f b a in + match Smart_git.Endpoint.of_string uri with + | Ok edn -> + let edn = + Option.fold ~none:edn + ~some:(!Smart_git.Endpoint.with_headers_if_http edn) + headers + in + (ctx, edn) + | Error (`Msg err) -> Fmt.invalid_arg "remote: %s" err + +module Maker (G : Irmin_git.G) = struct + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + + module Maker = Irmin_git.Maker (G) (Git.Mem.Sync (G)) + + module Make + (S : Irmin_git.Schema.S + with type Hash.t = G.hash + and type Node.t = G.Value.Tree.t + and type Commit.t = G.Value.Commit.t) = + struct + include Maker.Make (S) + + let remote ?ctx ?headers uri = E (remote ?ctx ?headers uri) + end +end + +module Ref (G : Irmin_git.G) = struct + module Maker = Irmin_git.Ref (G) (Git.Mem.Sync (G)) + module G = G + + type branch = Maker.branch + type endpoint = Maker.endpoint + + module Make (C : Irmin.Contents.S) = struct + include Maker.Make (C) + + let remote ?ctx ?headers uri = E (remote ?ctx ?headers uri) + end +end + +module KV (G : Irmin_git.G) = struct + module Maker = Irmin_git.KV (G) (Git.Mem.Sync (G)) + module G = G + + type endpoint = Maker.endpoint + type branch = Maker.branch + + module Make (C : Irmin.Contents.S) = struct + include Maker.Make (C) + + let remote ?ctx ?headers uri = E (remote ?ctx ?headers uri) + end +end + +module KV_RO (G : Git.S) = struct + module Key = Mirage_kv.Key + + type key = Key.t + + module G = struct + include G + + let v ?dotgit:_ _root = assert false + end + + module Maker = KV (G) + module S = Maker.Make (Irmin.Contents.String) + module Sync = Irmin.Sync.Make (S) + + let disconnect _ = Lwt.return_unit + + type error = [ Mirage_kv.error | S.write_error ] + + let pp_error ppf = function + | #Mirage_kv.error as e -> Mirage_kv.pp_error ppf e + | #S.write_error as e -> Irmin.Type.pp S.write_error_t ppf e + + let err e : ('a, error) result = Error e + let err_not_found k = err (`Not_found k) + + let path x = + (* XXX(samoht): we should probably just push the Key module in + Irmin and remove the path abstraction completely ... *) + Key.segments x + + module Tree = struct + type t = { repo : S.repo; tree : S.tree } + + let digest t key = + S.Tree.find_tree t.tree (path key) >|= function + | None -> err_not_found key + | Some tree -> + let h = S.Tree.hash tree in + Ok (Irmin.Type.to_string S.Hash.t h) + + let list t key = + S.Tree.list t.tree (path key) >|= fun l -> + let l = + List.map + (fun (s, k) -> + ( s, + match S.Tree.destruct k with + | `Contents _ -> `Value + | `Node _ -> `Dictionary )) + l + in + Ok l + + let exists t key = + S.Tree.kind t.tree (path key) >|= function + | Some `Contents -> Ok (Some `Value) + | Some `Node -> Ok (Some `Dictionary) + | None -> Ok None + + let get t key = + S.Tree.find t.tree (path key) >|= function + | None -> err_not_found key + | Some v -> Ok v + end + + type t = { root : S.path; t : S.t } + + let head_message t = + S.Head.find t.t >|= function + | None -> "empty HEAD" + | Some h -> + let info = S.Commit.info h in + Fmt.str "commit: %a\nAuthor: %s\nDate: %Ld\n\n%s\n" S.Commit.pp_hash h + (S.Info.author info) (S.Info.date info) (S.Info.message info) + + let last_modified t key = + let key' = path key in + S.last_modified t.t key' >|= function + | [] -> Error (`Not_found key) + | h :: _ -> Ok (0, S.Info.date (S.Commit.info h)) + + let connect ?depth ?(branch = "main") ?(root = Mirage_kv.Key.empty) ?ctx + ?headers t uri = + let remote = S.remote ?ctx ?headers uri in + let head = Git.Reference.v ("refs/heads/" ^ branch) in + S.repo_of_git ~bare:true ~head t >>= fun repo -> + S.of_branch repo branch >>= fun t -> + Sync.pull_exn t ?depth remote `Set >|= fun _ -> + let root = path root in + { t; root } + + let tree t = + let repo = S.repo t.t in + (S.find_tree t.t t.root >|= function + | None -> S.Tree.empty () + | Some tree -> tree) + >|= fun tree -> { Tree.repo; tree } + + let exists t k = tree t >>= fun t -> Tree.exists t k + let get t k = tree t >>= fun t -> Tree.get t k + let list t k = tree t >>= fun t -> Tree.list t k + let digest t k = tree t >>= fun t -> Tree.digest t k + + let get t k = + match Key.segments k with + | [ "HEAD" ] -> head_message t >|= fun v -> Ok v + | _ -> get t k +end + +module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct + (* XXX(samoht): batches are stored in memory. This could be bad if + large objects are stored for too long... Might be worth having + a clever LRU, which pushes larges objects to the underlying + layer when needed. *) + + module RO = KV_RO (G) + module S = RO.S + module Tree = RO.Tree + module Info = Irmin_mirage.Info (S.Info) (C) + + type batch = { repo : S.repo; mutable tree : S.tree; origin : S.commit } + + type store = Batch of batch | Store of RO.t + + and t = { + store : store; + author : unit -> string; + msg : [ `Set of RO.key | `Remove of RO.key | `Batch ] -> string; + remote : Irmin.remote; + } + + type key = RO.key + type error = RO.error + + let pp_error = RO.pp_error + let default_author () = "irmin " + + let default_msg = function + | `Set k -> Fmt.str "Updating %a" Mirage_kv.Key.pp k + | `Remove k -> Fmt.str "Removing %a" Mirage_kv.Key.pp k + | `Batch -> "Commmiting batch operation" + + let connect ?depth ?branch ?root ?ctx ?headers ?(author = default_author) + ?(msg = default_msg) git uri = + RO.connect ?depth ?branch ?root ?ctx ?headers git uri >|= fun t -> + let remote = S.remote ?ctx ?headers uri in + { store = Store t; author; msg; remote } + + let disconnect t = + match t.store with Store t -> RO.disconnect t | Batch _ -> Lwt.return_unit + + (* XXX(samoht): always return the 'last modified' on the + underlying storage layer, not for the current batch. *) + let last_modified t key = + match t.store with + | Store t -> RO.last_modified t key + | Batch b -> + RO.S.of_commit b.origin >>= fun t -> + RO.last_modified { root = S.Path.empty; t } key + + let repo t = match t.store with Store t -> S.repo t.t | Batch b -> b.repo + + let tree t = + match t.store with + | Store t -> RO.tree t + | Batch b -> Lwt.return { Tree.tree = b.tree; repo = repo t } + + let digest t k = tree t >>= fun t -> Tree.digest t k + let exists t k = tree t >>= fun t -> Tree.exists t k + let get t k = tree t >>= fun t -> Tree.get t k + let list t k = tree t >>= fun t -> Tree.list t k + + type write_error = [ RO.error | Mirage_kv.write_error | RO.Sync.push_error ] + + let write_error = function + | Ok _ -> Ok () + | Error e -> Error (e :> write_error) + + let pp_write_error ppf = function + | #RO.error as e -> RO.pp_error ppf e + | #RO.Sync.push_error as e -> RO.Sync.pp_push_error ppf e + | #Mirage_kv.write_error as e -> Mirage_kv.pp_write_error ppf e + + let info t op = Info.f ~author:(t.author ()) "%s" (t.msg op) + let path = RO.path + + let set t k v = + let info = info t (`Set k) in + match t.store with + | Store s -> ( + S.set ~info s.t (path k) v >>= function + | Ok _ -> RO.Sync.push s.t t.remote >|= write_error + | Error e -> Lwt.return (Error (e :> write_error))) + | Batch b -> + S.Tree.add b.tree (path k) v >|= fun tree -> + b.tree <- tree; + Ok () + + let remove t k = + let info = info t (`Remove k) in + match t.store with + | Store s -> ( + S.remove ~info s.t (path k) >>= function + | Ok _ -> RO.Sync.push s.t t.remote >|= write_error + | Error e -> Lwt.return (Error (e :> write_error))) + | Batch b -> + S.Tree.remove b.tree (path k) >|= fun tree -> + b.tree <- tree; + Ok () + + let get_store_tree (t : RO.t) = + S.Head.find t.t >>= function + | None -> Lwt.return_none + | Some origin -> ( + let tree = S.Commit.tree origin in + S.Tree.find_tree tree t.root >|= function + | Some t -> Some (origin, t) + | None -> Some (origin, S.Tree.empty ())) + + let batch t ?(retries = 42) f = + let info = info t `Batch in + let one t = + match t.store with + | Batch _ -> Fmt.failwith "No recursive batches" + | Store s -> ( + let repo = S.repo s.t in + (* get the tree origin *) + get_store_tree s >>= function + | None -> f t >|= fun x -> Ok x (* no transaction is needed *) + | Some (origin, old_tree) -> ( + let batch = { repo; tree = old_tree; origin } in + let b = Batch batch in + f { t with store = b } >>= fun result -> + get_store_tree s >>= function + | None -> + (* Someting weird happened, retring *) + Lwt.return (Error `Retry) + | Some (_, main_tree) -> ( + Irmin.Merge.f S.Tree.merge + ~old:(Irmin.Merge.promise old_tree) + main_tree batch.tree + >>= function + | Error (`Conflict _) -> Lwt.return (Error `Retry) + | Ok new_tree -> ( + S.set_tree s.t ~info s.root new_tree >|= function + | Ok () -> Ok result + | Error _ -> Error `Retry)))) + in + let rec loop = function + | 0 -> Lwt.fail_with "Too many retries" + | n -> ( + one t >>= function + | Error `Retry -> loop (n - 1) + | Ok r -> Lwt.return r) + in + loop retries >>= fun r -> + match t.store with + | Batch _ -> Fmt.failwith "No recursive batches" + | Store s -> ( + RO.Sync.push s.t t.remote >>= function + | Ok _ -> Lwt.return r + | Error e -> Lwt.fail_with (Fmt.to_to_string RO.Sync.pp_push_error e)) +end + +module Mem = struct + module G = Irmin_git.Mem + include Maker (G) + + module Maker = struct + module Ref = Ref (G) + module KV = KV (G) + end + + module Ref = Maker.Ref + module KV = Maker.KV + module KV_RO = KV_RO (G) + module KV_RW = KV_RW (G) +end diff --git a/vendors/irmin/src/irmin-mirage/git/irmin_mirage_git.mli b/vendors/irmin/src/irmin-mirage/git/irmin_mirage_git.mli new file mode 100644 index 0000000000000000000000000000000000000000..856bab30055c89b09b6eae868c7595bbc51c23b8 --- /dev/null +++ b/vendors/irmin/src/irmin-mirage/git/irmin_mirage_git.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin_mirage_git_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-mirage/git/irmin_mirage_git_intf.ml b/vendors/irmin/src/irmin-mirage/git/irmin_mirage_git_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..983aa5913fc0faf98f5b12274459dec3bdf02d65 --- /dev/null +++ b/vendors/irmin/src/irmin-mirage/git/irmin_mirage_git_intf.ml @@ -0,0 +1,150 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + include + Irmin_git.S + with type Backend.Remote.endpoint = Mimic.ctx * Smart_git.Endpoint.t + + val remote : + ?ctx:Mimic.ctx -> ?headers:(string * string) list -> string -> Irmin.remote +end + +module type Maker = sig + module G : Irmin_git.G + + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + + module Make + (Schema : Irmin_git.Schema.S + with type Hash.t = G.hash + with type Node.t = G.Value.Tree.t + and type Commit.t = G.Value.Commit.t) : + S + with module Git = G + and type Backend.Remote.endpoint = endpoint + and module Schema := Schema +end + +module type KV_maker = sig + module G : Irmin_git.G + + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + type branch + + module Make (C : Irmin.Contents.S) : + S + with module Git = G + and type Schema.Contents.t = C.t + and module Schema.Metadata = Irmin_git.Metadata + and type Schema.Info.t = Irmin.Info.default + and type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Hash.t = G.hash + and type Schema.Branch.t = branch + and type Backend.Remote.endpoint = endpoint +end + +module type KV_RO = sig + type git + + include Mirage_kv.RO + + val connect : + ?depth:int -> + ?branch:string -> + ?root:key -> + ?ctx:Mimic.ctx -> + ?headers:(string * string) list -> + git -> + string -> + t Lwt.t + (** [connect ?depth ?branch ?path g uri] clones the given [uri] into [g] + repository, using the given [branch], [depth] and ['/']-separated + sub-[path]. By default, [branch] is main, [depth] is [1] and [path] is + empty, ie. reads will be relative to the root of the repository. *) +end + +module type KV_RW = sig + type git + + include Mirage_kv.RW + + val connect : + ?depth:int -> + ?branch:string -> + ?root:key -> + ?ctx:Mimic.ctx -> + ?headers:(string * string) list -> + ?author:(unit -> string) -> + ?msg:([ `Set of key | `Remove of key | `Batch ] -> string) -> + git -> + string -> + t Lwt.t + (** [connect ?depth ?branch ?path ?author ?msg g c uri] clones the given [uri] + into [g] repository, using the given [branch], [depth] and ['/']-separated + sub-[path]. By default, [branch] is main, [depth] is [1] and [path] is + empty, ie. reads will be relative to the root of the repository. [author], + [msg] and [c] are used to create new commit info values on every update. + By defaut [author] is [fun () -> "irmin" ] and [msg] + returns basic information about the kind of operations performed. *) +end + +module type Sigs = sig + module type S = S + module type Maker = Maker + module type KV_maker = KV_maker + module type KV_RO = KV_RO + module type KV_RW = KV_RW + + module Maker (G : Irmin_git.G) : Maker with module G := G + + module KV (G : Irmin_git.G) : + KV_maker with type branch = string and module G := G + + module Ref (G : Irmin_git.G) : + KV_maker with type branch = Irmin_git.reference and module G := G + + (** Functor to create a MirageOS' KV_RO store from a Git repository. The key + ["/HEAD"] always shows the current HEAD. *) + module KV_RO (G : Irmin_git.G) : KV_RO with type git := G.t + + (** Functor to create a MirageOS' KV_RW store from a Git repository. *) + module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) : + KV_RW with type git := G.t + + (** Embed an Irmin store into an in-memory Git repository. *) + module Mem : sig + module G : Irmin_git.G + + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + + module Make + (Schema : Irmin_git.Schema.S + with type Hash.t = G.hash + and type Node.t = G.Value.Tree.t + and type Commit.t = G.Value.Commit.t) : + S + with module Git = G + and type Backend.Remote.endpoint = endpoint + and module Schema := Schema + + module Ref : KV_maker with type branch = Irmin_git.reference + module KV : KV_maker with type branch = string + module KV_RO : KV_RO with type git := G.t + module KV_RW (C : Mirage_clock.PCLOCK) : KV_RW with type git := G.t + end +end diff --git a/vendors/irmin/src/irmin-mirage/graphql/dune b/vendors/irmin/src/irmin-mirage/graphql/dune new file mode 100644 index 0000000000000000000000000000000000000000..e159ea75a81b6b3df05f2ab5fcb7bac855290716 --- /dev/null +++ b/vendors/irmin/src/irmin-mirage/graphql/dune @@ -0,0 +1,14 @@ +(library + (name irmin_mirage_graphql) + (public_name irmin-mirage-graphql) + (libraries + git.nss.git + cohttp-lwt + irmin + irmin-mirage + irmin-graphql + lwt + mirage-clock + uri) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-mirage/graphql/irmin_mirage_graphql.ml b/vendors/irmin/src/irmin-mirage/graphql/irmin_mirage_graphql.ml new file mode 100644 index 0000000000000000000000000000000000000000..d582b40676c1e881c74f1398bebd3661fd623472 --- /dev/null +++ b/vendors/irmin/src/irmin-mirage/graphql/irmin_mirage_graphql.ml @@ -0,0 +1,73 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Server = struct + module type S = sig + module Pclock : Mirage_clock.PCLOCK + module Http : Cohttp_lwt.S.Server + + module Store : + Irmin.S with type Backend.Remote.endpoint = Smart_git.Endpoint.t + + val start : http:(Http.t -> unit Lwt.t) -> Store.repo -> unit Lwt.t + end + + module Make + (Http : Cohttp_lwt.S.Server) + (Store : Irmin.S with type Backend.Remote.endpoint = Smart_git.Endpoint.t) + (Pclock : Mirage_clock.PCLOCK) = + struct + module Store = Store + module Pclock = Pclock + module Http = Http + + let init () = + let module Config = struct + type info = Store.info + + let info ?(author = "irmin-graphql") fmt = + let module I = Irmin_mirage.Info (Store.Info) (Pclock) in + I.f ~author fmt + + let remote = + Some + (fun ?headers uri -> + let ( ! ) f a b = f b a in + let headers = Option.map Cohttp.Header.to_list headers in + match Smart_git.Endpoint.of_string uri with + | Ok + ({ Smart_git.Endpoint.scheme = `HTTP _ | `HTTPS _; _ } as edn) + -> + let edn = + Option.fold ~none:edn + ~some:(!Smart_git.Endpoint.with_headers_if_http edn) + headers + in + Lwt.return (Store.E edn) + | Ok _ -> Fmt.invalid_arg "invalid remote: %s" uri + | Error (`Msg err) -> Fmt.invalid_arg "invalid remote: %s" err) + end in + (module Irmin_graphql.Server.Make (Http) (Config) (Store) + : Irmin_graphql.Server.S + with type server = Http.t + and type repo = Store.repo) + + let start ~http store = + let (module G) = init () in + let server = G.v store in + http server + end +end diff --git a/vendors/irmin/src/irmin-mirage/graphql/irmin_mirage_graphql.mli b/vendors/irmin/src/irmin-mirage/graphql/irmin_mirage_graphql.mli new file mode 100644 index 0000000000000000000000000000000000000000..ff824b07abc08d405ed021eb37ecc4b26f7cb941 --- /dev/null +++ b/vendors/irmin/src/irmin-mirage/graphql/irmin_mirage_graphql.mli @@ -0,0 +1,36 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Server : sig + module type S = sig + module Pclock : Mirage_clock.PCLOCK + module Http : Cohttp_lwt.S.Server + + module Store : + Irmin.S with type Backend.Remote.endpoint = Smart_git.Endpoint.t + + val start : http:(Http.t -> unit Lwt.t) -> Store.repo -> unit Lwt.t + end + + module Make + (Http : Cohttp_lwt.S.Server) + (Store : Irmin.S with type Backend.Remote.endpoint = Smart_git.Endpoint.t) + (Pclock : Mirage_clock.PCLOCK) : + S + with module Pclock = Pclock + and module Store = Store + and module Http = Http +end diff --git a/vendors/irmin/src/irmin-mirage/irmin_mirage.ml b/vendors/irmin/src/irmin-mirage/irmin_mirage.ml new file mode 100644 index 0000000000000000000000000000000000000000..4a65f51c1fb228e93658acc2b08ada43cb1342e2 --- /dev/null +++ b/vendors/irmin/src/irmin-mirage/irmin_mirage.ml @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Info (Info : Irmin.Info.S) (C : Mirage_clock.PCLOCK) = struct + let f ~author fmt = + Fmt.kstr + (fun message () -> + C.now_d_ps () |> Ptime.v |> Ptime.to_float_s |> Int64.of_float + |> fun date -> Info.v ~author ~message date) + fmt +end diff --git a/vendors/irmin/src/irmin-mirage/irmin_mirage.mli b/vendors/irmin/src/irmin-mirage/irmin_mirage.mli new file mode 100644 index 0000000000000000000000000000000000000000..4ecd99a9d57d1f88c1764eec91296bd787fa2472 --- /dev/null +++ b/vendors/irmin/src/irmin-mirage/irmin_mirage.mli @@ -0,0 +1,27 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** MirageOS backend, with bi-directional compatibility with Git *) + +(** The context to use for synchronisation. *) + +module Info (Info : Irmin.Info.S) (C : Mirage_clock.PCLOCK) : sig + (** {1 Commit info creators} *) + + val f : author:string -> ('a, Format.formatter, unit, Info.f) format4 -> 'a + (** [f ~author msg] is a new commit info with [author] as commit author, + [C.now_d_ps ()] as commit date and [msg] as commit message.*) +end diff --git a/vendors/irmin/src/irmin-pack/atomic_write.ml b/vendors/irmin/src/irmin-pack/atomic_write.ml new file mode 100644 index 0000000000000000000000000000000000000000..7ee92ec4f63b33fb7afe9e389bbf15fd2a63e809 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/atomic_write.ml @@ -0,0 +1,94 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Atomic_write_intf + +module Value = struct + module type S = Value + + module Of_hash (X : Irmin.Hash.S) = struct + type t = X.t [@@deriving irmin ~of_bin_string] + + let null = + match of_bin_string (String.make X.hash_size '\000') with + | Ok x -> x + | Error _ -> assert false + end +end + +(* FIXME: remove code duplication with irmin/atomic_write *) +module Closeable (AW : S) = struct + type t = { closed : bool ref; t : AW.t } + type key = AW.key + type value = AW.value + + let check_not_closed t = if !(t.closed) then raise Irmin.Closed + + let mem t k = + check_not_closed t; + AW.mem t.t k + + let find t k = + check_not_closed t; + AW.find t.t k + + let set t k v = + check_not_closed t; + AW.set t.t k v + + let test_and_set t k ~test ~set = + check_not_closed t; + AW.test_and_set t.t k ~test ~set + + let remove t k = + check_not_closed t; + AW.remove t.t k + + let list t = + check_not_closed t; + AW.list t.t + + type watch = AW.watch + + let watch t ?init f = + check_not_closed t; + AW.watch t.t ?init f + + let watch_key t k ?init f = + check_not_closed t; + AW.watch_key t.t k ?init f + + let unwatch t w = + check_not_closed t; + AW.unwatch t.t w + + let make_closeable t = { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + AW.close t.t) + + let clear t = + check_not_closed t; + AW.clear t.t + + let flush t = + check_not_closed t; + AW.flush t.t +end diff --git a/vendors/irmin/src/irmin-pack/atomic_write.mli b/vendors/irmin/src/irmin-pack/atomic_write.mli new file mode 100644 index 0000000000000000000000000000000000000000..e71e0673a37b2f0941695900f66fa9cb42f3fb5d --- /dev/null +++ b/vendors/irmin/src/irmin-pack/atomic_write.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Atomic_write_intf.Sigs diff --git a/vendors/irmin/src/irmin-pack/atomic_write_intf.ml b/vendors/irmin/src/irmin-pack/atomic_write_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..96b35e0542ffea10a6c713e01ca018113d4453b9 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/atomic_write_intf.ml @@ -0,0 +1,56 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + include Irmin.Atomic_write.S + + val flush : t -> unit +end + +module type Persistent = sig + include S + + val v : ?fresh:bool -> ?readonly:bool -> string -> t Lwt.t +end + +module type Value = sig + include Irmin.Type.S + + val null : t + (** A special value that is reserved for use by the implementation of + {!Make_persistent} (and must never be passed by the user). *) +end + +module type Sigs = sig + module type S = S + module type Persistent = Persistent + + module Value : sig + module type S = Value + + module Of_hash (X : Irmin.Hash.S) : S with type t = X.t + end + + module Closeable (AW : S) : sig + include + S + with type key = AW.key + and type value = AW.value + and type watch = AW.watch + + val make_closeable : AW.t -> t + end +end diff --git a/vendors/irmin/src/irmin-pack/conf.ml b/vendors/irmin/src/irmin-pack/conf.ml new file mode 100644 index 0000000000000000000000000000000000000000..cd887d9c8fe9c26aceb274a4ec84d791b42d2bb9 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/conf.ml @@ -0,0 +1,151 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type length_header = [ `Varint ] option + +type inode_child_order = + [ `Seeded_hash | `Hash_bits | `Custom of depth:int -> bytes -> int ] + +module type S = sig + val entries : int + val stable_hash : int + val contents_length_header : length_header + val inode_child_order : inode_child_order + val forbid_empty_dir_persistence : bool +end + +module Default = struct + let fresh = false + let lru_size = 100_000 + let index_log_size = 2_500_000 + let readonly = false + let merge_throttle = `Block_writes + let indexing_strategy = Indexing_strategy.default + let use_fsync = false + let dict_auto_flush_threshold = 1_000_000 + let suffix_auto_flush_threshold = 1_000_000 + let no_migrate = false +end + +open Irmin.Backend.Conf + +let spec = Spec.v "pack" + +type merge_throttle = [ `Block_writes | `Overcommit_memory ] [@@deriving irmin] + +module Key = struct + let fresh = + key ~spec ~doc:"Start with a fresh disk." "fresh" Irmin.Type.bool + Default.fresh + + let lru_size = + key ~spec ~doc:"Size of the LRU cache for pack entries." "lru-size" + Irmin.Type.int Default.lru_size + + let index_log_size = + key ~spec ~doc:"Size of index logs." "index-log-size" Irmin.Type.int + Default.index_log_size + + let readonly = + key ~spec ~doc:"Start with a read-only disk." "readonly" Irmin.Type.bool + Default.readonly + + let merge_throttle = + key ~spec + ~doc:"Strategy to use for large writes when index caches are full." + "merge-throttle" merge_throttle_t Default.merge_throttle + + let root = root spec + + let indexing_strategy = + let serialisable_t = [%typ: [ `Always | `Minimal ]] in + key ~spec ~doc:"Strategy to use for adding objects to the index" + "indexing-strategy" + (Irmin.Type.map serialisable_t + (function + | `Always -> Indexing_strategy.always + | `Minimal -> Indexing_strategy.minimal) + (fun _ -> Fmt.failwith "Can't serialise indexing strategy")) + Default.indexing_strategy + + let use_fsync = + key ~spec + ~doc:"Whether fsync should be used to ensure persistence order of files" + "use-fsync" Irmin.Type.bool Default.use_fsync + + let dict_auto_flush_threshold = + key ~spec ~doc:"Buffer size of the dict at which automatic flushes occur" + "dict-auto-flush-threshold" Irmin.Type.int + Default.dict_auto_flush_threshold + + let suffix_auto_flush_threshold = + key ~spec ~doc:"Buffer size of the suffix at which automatic flushes occur" + "suffix-auto-flush-threshold" Irmin.Type.int + Default.suffix_auto_flush_threshold + + let no_migrate = + key ~spec ~doc:"Prevent migration of V1 and V2 stores" "no-migrate" + Irmin.Type.bool Default.no_migrate +end + +let fresh config = get config Key.fresh +let lru_size config = get config Key.lru_size +let readonly config = get config Key.readonly +let index_log_size config = get config Key.index_log_size +let merge_throttle config = get config Key.merge_throttle + +let root config = + match find_root config with + | None -> + failwith + "unintialised root, call [Irmin_pack.Conf.init root] before opening \ + the store" + | Some root -> root + +let indexing_strategy config = get config Key.indexing_strategy +let use_fsync config = get config Key.use_fsync +let dict_auto_flush_threshold config = get config Key.dict_auto_flush_threshold + +let suffix_auto_flush_threshold config = + get config Key.suffix_auto_flush_threshold + +let no_migrate config = get config Key.no_migrate + +let init ?(fresh = Default.fresh) ?(readonly = Default.readonly) + ?(lru_size = Default.lru_size) ?(index_log_size = Default.index_log_size) + ?(merge_throttle = Default.merge_throttle) + ?(indexing_strategy = Default.indexing_strategy) + ?(use_fsync = Default.use_fsync) + ?(dict_auto_flush_threshold = Default.dict_auto_flush_threshold) + ?(suffix_auto_flush_threshold = Default.suffix_auto_flush_threshold) + ?(no_migrate = Default.no_migrate) root = + let config = empty spec in + let config = add config Key.root root in + let config = add config Key.fresh fresh in + let config = add config Key.lru_size lru_size in + let config = add config Key.index_log_size index_log_size in + let config = add config Key.readonly readonly in + let config = add config Key.merge_throttle merge_throttle in + let config = add config Key.indexing_strategy indexing_strategy in + let config = add config Key.use_fsync use_fsync in + let config = + add config Key.dict_auto_flush_threshold dict_auto_flush_threshold + in + let config = + add config Key.suffix_auto_flush_threshold suffix_auto_flush_threshold + in + let config = add config Key.no_migrate no_migrate in + verify config diff --git a/vendors/irmin/src/irmin-pack/conf.mli b/vendors/irmin/src/irmin-pack/conf.mli new file mode 100644 index 0000000000000000000000000000000000000000..0da1e4b26964432885f40b91f5bad613d00f9222 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/conf.mli @@ -0,0 +1,94 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type length_header = [ `Varint ] option + +type inode_child_order = + [ `Seeded_hash (** use a non-crypto seeded-hash of the step *) + | `Hash_bits (** crypto hash the step and extract the relevant bits. *) + | `Custom of depth:int -> bytes -> int (** use a custom index *) ] + +module type S = sig + val entries : int + val stable_hash : int + + val contents_length_header : length_header + (** Describes the length header of the user's contents values when + binary-encoded. Supported modes are: + + - [Some `Varint]: the length header is a LEB128-encoded integer at the + very beginning of the encoded value. + + - [None]: there is no length header, and values have unknown size. NOTE: + when using [irmin-pack] in this mode, the selected indexing strategy + {i must} index all contents values (as recovering contents values from + the store will require referring to the index for their length + information). *) + + val inode_child_order : inode_child_order + + val forbid_empty_dir_persistence : bool + (** If [true], irmin-pack raises [Failure] if it is asked to save the empty + inode. This default is [false]. It should be set to [true] if the [Schema] + of the store allows a hash collision between the empty inode and this + string of length 1: ["\000"]. + + See https://github.com/mirage/irmin/issues/1304 *) +end + +val spec : Irmin.Backend.Conf.Spec.t + +type merge_throttle = [ `Block_writes | `Overcommit_memory ] [@@deriving irmin] + +module Key : sig + val fresh : bool Irmin.Backend.Conf.key + val lru_size : int Irmin.Backend.Conf.key + val index_log_size : int Irmin.Backend.Conf.key + val readonly : bool Irmin.Backend.Conf.key + val root : string Irmin.Backend.Conf.key + val merge_throttle : merge_throttle Irmin.Backend.Conf.key + val indexing_strategy : Indexing_strategy.t Irmin.Backend.Conf.key + val use_fsync : bool Irmin.Backend.Conf.key + val dict_auto_flush_threshold : int Irmin.Backend.Conf.key + val suffix_auto_flush_threshold : int Irmin.Backend.Conf.key + val no_migrate : bool Irmin.Backend.Conf.key +end + +val fresh : Irmin.Backend.Conf.t -> bool +val lru_size : Irmin.Backend.Conf.t -> int +val index_log_size : Irmin.Backend.Conf.t -> int +val readonly : Irmin.Backend.Conf.t -> bool +val merge_throttle : Irmin.Backend.Conf.t -> merge_throttle +val root : Irmin.Backend.Conf.t -> string +val indexing_strategy : Irmin.Backend.Conf.t -> Indexing_strategy.t +val use_fsync : Irmin.Backend.Conf.t -> bool +val dict_auto_flush_threshold : Irmin.Backend.Conf.t -> int +val suffix_auto_flush_threshold : Irmin.Backend.Conf.t -> int +val no_migrate : Irmin.Backend.Conf.t -> bool + +val init : + ?fresh:bool -> + ?readonly:bool -> + ?lru_size:int -> + ?index_log_size:int -> + ?merge_throttle:merge_throttle -> + ?indexing_strategy:Indexing_strategy.t -> + ?use_fsync:bool -> + ?dict_auto_flush_threshold:int -> + ?suffix_auto_flush_threshold:int -> + ?no_migrate:bool -> + string -> + Irmin.config diff --git a/vendors/irmin/src/irmin-pack/dune b/vendors/irmin/src/irmin-pack/dune new file mode 100644 index 0000000000000000000000000000000000000000..e62d63c7246163f567b33b2f77e317893c2c7278 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/dune @@ -0,0 +1,8 @@ +(library + (public_name irmin-pack) + (name irmin_pack) + (libraries fmt irmin irmin.data logs lwt optint) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-pack/import.ml b/vendors/irmin/src/irmin-pack/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..f6601d6c7b51ea3aa400212b9bec62e7515ab8d2 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/import.ml @@ -0,0 +1,29 @@ +(* + * Copyright (c)2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends + +let src = Logs.Src.create "irmin.pack" ~doc:"irmin-pack backend" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Int63 = struct + include Optint.Int63 + + let t = Irmin.Type.int63 +end + +type int63 = Int63.t [@@deriving irmin] diff --git a/vendors/irmin/src/irmin-pack/indexable.ml b/vendors/irmin/src/irmin-pack/indexable.ml new file mode 100644 index 0000000000000000000000000000000000000000..e16ee6d0c8b915da25a93cb5b20ac8923610fa18 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/indexable.ml @@ -0,0 +1,82 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Indexable_intf +open! Import + +(* FIXME: remove code duplication with irmin/indexable *) +module Closeable (S : S) = struct + type 'a t = { closed : bool ref; t : 'a S.t } + type key = S.key + type hash = S.hash + type value = S.value + + module Key = S.Key + + let check_not_closed t = if !(t.closed) then raise Irmin.Closed + + let mem t k = + check_not_closed t; + S.mem t.t k + + let find t k = + check_not_closed t; + S.find t.t k + + let index t h = + check_not_closed t; + S.index t.t h + + let index_direct t h = + check_not_closed t; + S.index_direct t.t h + + let add t v = + check_not_closed t; + S.add t.t v + + let unsafe_add t k v = + check_not_closed t; + S.unsafe_add t.t k v + + let batch t f = + check_not_closed t; + S.batch t.t (fun w -> f { t = w; closed = t.closed }) + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) + + let unsafe_append ~ensure_unique ~overcommit t k v = + check_not_closed t; + S.unsafe_append ~ensure_unique ~overcommit t.t k v + + let unsafe_mem t k = + check_not_closed t; + S.unsafe_mem t.t k + + let unsafe_find ~check_integrity t k = + check_not_closed t; + S.unsafe_find ~check_integrity t.t k + + let make_closeable t = { closed = ref false; t } + + let get_open_exn t = + check_not_closed t; + t.t +end diff --git a/vendors/irmin/src/irmin-pack/indexable.mli b/vendors/irmin/src/irmin-pack/indexable.mli new file mode 100644 index 0000000000000000000000000000000000000000..a933b97da2d2fd6fcdad53af84d971e372edc096 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/indexable.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Indexable_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/indexable_intf.ml b/vendors/irmin/src/irmin-pack/indexable_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..3867797d45bea32424550fd2adf92c2120bb5072 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/indexable_intf.ml @@ -0,0 +1,56 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + include Irmin.Indexable.S + + val add : 'a t -> value -> key Lwt.t + (** Overwrite [add] to work with a read-only database handler. *) + + val unsafe_add : 'a t -> hash -> value -> key Lwt.t + (** Overwrite [unsafe_add] to work with a read-only database handler. *) + + val index_direct : _ t -> hash -> key option + + val unsafe_append : + ensure_unique:bool -> overcommit:bool -> 'a t -> hash -> value -> key + + val unsafe_mem : 'a t -> key -> bool + val unsafe_find : check_integrity:bool -> 'a t -> key -> value option +end + +module type Maker = sig + type key + + (** Save multiple kind of values in the same pack file. Values will be + distinguished using [V.kind], so they have to all be different. *) + module Make (V : Pack_value.S with type hash := key) : + S with type key = key and type value = V.t +end + +module type Sigs = sig + module type S = S + + module Closeable (CA : S) : sig + include + S with type key = CA.key and type hash = CA.hash and type value = CA.value + + val make_closeable : 'a CA.t -> 'a t + val get_open_exn : 'a t -> 'a CA.t + end +end diff --git a/vendors/irmin/src/irmin-pack/indexing_strategy.ml b/vendors/irmin/src/irmin-pack/indexing_strategy.ml new file mode 100644 index 0000000000000000000000000000000000000000..eead0137b548f5569e248ea5df9b647f91fe9d5d --- /dev/null +++ b/vendors/irmin/src/irmin-pack/indexing_strategy.ml @@ -0,0 +1,52 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type t = value_length:int -> Pack_value.Kind.t -> bool + +let always ~value_length:_ _ = true + +let minimal : t = + fun ~value_length:_ -> function + | Commit_v2 -> + (* Commits must be indexed as the branch store contains only their + hashes. All {i internal} references to V1 commits are via offset + (from other V1 commit objects). *) + true + | Inode_v2_root -> + (* It's safe not to index V1 root inodes because they are never + referenced by V0 commit objects (only V1 commit objects, which + contain direct pointers rather than hashes).*) + false + | Inode_v2_nonroot -> false + | Contents -> false + | Commit_v1 | Inode_v1_unstable | Inode_v1_stable -> + (* We never append new V0 values, so this choice is irrelevant to the + store implementation, but we do assume that existing V0 objects are + indexed (as they may be referenced via hash by other V0 objects), and + this must be accounted for when reconstructing the index. *) + true + | Dangling_parent_commit -> assert false + +let minimal_with_contents : t = + fun ~value_length:_ -> function + | Commit_v2 -> true + | Inode_v2_root -> false + | Inode_v2_nonroot -> false + | Contents -> true + | Commit_v1 | Inode_v1_unstable | Inode_v1_stable -> true + | Dangling_parent_commit -> assert false + +let default = always diff --git a/vendors/irmin/src/irmin-pack/indexing_strategy.mli b/vendors/irmin/src/irmin-pack/indexing_strategy.mli new file mode 100644 index 0000000000000000000000000000000000000000..3bc657c027ef3f057cd40eeca6262c8512ecf81d --- /dev/null +++ b/vendors/irmin/src/irmin-pack/indexing_strategy.mli @@ -0,0 +1,44 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type t = value_length:int -> Pack_value.Kind.t -> bool +(** The type of configurations for [irmin-pack]'s indexing strategy, which + dictates whether or not newly-appended pack entries should also be added to + the index. Strategies are parameterised over: + + - the length of the binary encoding of the {i object} inside the pack entry + (i.e. not accounting for the encoded hash and kind character); + - the kind of the pack object having been added. + + Indexing more than the {!minimal} strategy only impacts performance and not + correctness: more indexing results in a larger index and a smaller pack + file. *) + +val always : t +(** The strategy that indexes all objects. *) + +val minimal : t +(** The strategy that indexes as few objects as possible while still maintaing + store integrity. *) + +val minimal_with_contents : t +(** The strategy that is similar to the minimal strategy but it also indexes + contents objects. *) + +val default : t +(** [default] is the indexing strategy used by [irmin-pack] instances that do + not explicitly set an indexing strategy in {!Irmin_pack.config}. Currently + set to {!always}. *) diff --git a/vendors/irmin/src/irmin-pack/inode.ml b/vendors/irmin/src/irmin-pack/inode.ml new file mode 100644 index 0000000000000000000000000000000000000000..f2232effeb2a5b0fa5c2c318b11ef71d68ed93ad --- /dev/null +++ b/vendors/irmin/src/irmin-pack/inode.ml @@ -0,0 +1,2382 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Inode_intf + +exception Max_depth of int + +module Make_internal + (Conf : Conf.S) + (H : Irmin.Hash.S) (Key : sig + include Irmin.Key.S with type hash = H.t + + val unfindable_of_hash : hash -> t + end) + (Node : Irmin.Node.Generic_key.S + with type hash = H.t + and type contents_key = Key.t + and type node_key = Key.t) = +struct + (** If [should_be_stable ~length ~root] is true for an inode [i], then [i] + hashes the same way as a [Node.t] containing the same entries. *) + let should_be_stable ~length ~root = + if length = 0 then true + else if not root then false + else if length <= Conf.stable_hash then true + else false + + module Node = struct + include Node + module H = Irmin.Hash.Typed (H) (Node) + + let hash = H.hash + end + + (* Keep at most 50 bits of information. *) + let max_depth = int_of_float (log (2. ** 50.) /. log (float Conf.entries)) + + module T = struct + type hash = H.t [@@deriving irmin ~pp ~to_bin_string ~equal] + type key = Key.t [@@deriving irmin ~pp ~equal] + type node_key = Node.node_key [@@deriving irmin] + type contents_key = Node.contents_key [@@deriving irmin] + + type step = Node.step + [@@deriving irmin ~compare ~to_bin_string ~of_bin_string ~short_hash] + + type metadata = Node.metadata [@@deriving irmin ~equal] + type value = Node.value [@@deriving irmin ~equal] + + module Metadata = Node.Metadata + + exception Dangling_hash = Node.Dangling_hash + + let raise_dangling_hash c hash = + let context = "Irmin_pack.Inode." ^ c in + raise (Dangling_hash { context; hash }) + + let unsafe_keyvalue_of_hashvalue = function + | `Contents (h, m) -> `Contents (Key.unfindable_of_hash h, m) + | `Node h -> `Node (Key.unfindable_of_hash h) + + let hashvalue_of_keyvalue = function + | `Contents (k, m) -> `Contents (Key.to_hash k, m) + | `Node k -> `Node (Key.to_hash k) + end + + module Step = + Irmin.Hash.Typed + (H) + (struct + type t = T.step + + let t = T.step_t + end) + + module Child_ordering : Child_ordering with type step := T.step = struct + open T + + type key = bytes + + let log_entry = int_of_float (log (float Conf.entries) /. log 2.) + + let () = + assert (log_entry >= 1); + (* NOTE: the [`Hash_bits] mode is restricted to inodes with at most 1024 + entries in order to simplify the implementation (see below). *) + assert ((not (Conf.inode_child_order = `Hash_bits)) || log_entry <= 10); + assert (Conf.entries = int_of_float (2. ** float log_entry)) + + let key = + match Conf.inode_child_order with + | `Hash_bits -> + (* Bytes.unsafe_of_string usage: possibly safe TODO justify safety, or switch to + use the safe Bytes.of_string *) + fun s -> Bytes.unsafe_of_string (hash_to_bin_string (Step.hash s)) + | `Seeded_hash | `Custom _ -> + (* Bytes.unsafe_of_string usage: possibly safe TODO justify safety, or switch to + use the safe Bytes.of_string *) + fun s -> Bytes.unsafe_of_string (step_to_bin_string s) + + (* Assume [k = cryto_hash(step)] (see {!key}) and [Conf.entry] can + can represented with [n] bits. Then, [hash_bits ~depth k] is + the [n]-bits integer [i] with the following binary representation: + + [k(n*depth) ... k(n*depth+n-1)] + + When [n] is not a power of 2, [hash_bits] needs to handle + unaligned reads properly. *) + let hash_bits ~depth k = + assert (Bytes.length k = Step.hash_size); + (* We require above that the child indices have at most 10 bits to ensure + that they span no more than 2 bytes of the step hash. The 3 byte case + (with [1 + 8 + 1]) does not happen for 10-bit indices because 10 is + even, but [2 + 8 + 1] would occur with 11-byte indices (e.g. when + [depth=2]). *) + let byte = 8 in + let initial_bit_pos = log_entry * depth in + let n = initial_bit_pos / byte in + let r = initial_bit_pos mod byte in + if n >= Step.hash_size then raise (Max_depth depth); + if r + log_entry <= byte then + (* The index is contained in a single character of the hash *) + let i = Bytes.get_uint8 k n in + let e0 = i lsr (byte - log_entry - r) in + let r0 = e0 land (Conf.entries - 1) in + r0 + else + (* The index spans two characters of the hash *) + let i0 = Bytes.get_uint8 k n in + let to_read = byte - r in + let rest = log_entry - to_read in + let mask = (1 lsl to_read) - 1 in + let r0 = (i0 land mask) lsl rest in + if n + 1 >= Step.hash_size then raise (Max_depth depth); + let i1 = Bytes.get_uint8 k (n + 1) in + let r1 = i1 lsr (byte - rest) in + r0 + r1 + + let short_hash = Irmin.Type.(unstage (short_hash bytes)) + let seeded_hash ~depth k = abs (short_hash ~seed:depth k) mod Conf.entries + + let index = + match Conf.inode_child_order with + | `Seeded_hash -> seeded_hash + | `Hash_bits -> hash_bits + | `Custom f -> f + end + + module StepMap = struct + include Map.Make (struct + type t = T.step + + let compare = T.compare_step + end) + + let of_list l = List.fold_left (fun acc (k, v) -> add k v acc) empty l + end + + module Val_ref : sig + open T + + type t [@@deriving irmin] + type v = private Key of Key.t | Hash of hash Lazy.t + + val inspect : t -> v + val of_key : key -> t + val of_hash : hash Lazy.t -> t + val promote_exn : t -> key -> unit + val to_hash : t -> hash + val to_key_exn : t -> key + val is_key : t -> bool + end = struct + open T + + (** Nodes that have been persisted to an underlying store are referenced via + keys. Otherwise, when building in-memory inodes (e.g. via [Portable] or + [of_concrete_exn]) lazily-computed hashes are used instead. If such + values are persisted, the hash reference can be promoted to a key + reference (but [Key] values are never demoted to hashes). + + NOTE: in future, we could reflect the case of this type in a type + parameter and refactor the [layout] types below to get static guarantees + that [Portable] nodes (with hashes for internal pointers) are not saved + without first saving their children. *) + type v = Key of Key.t | Hash of hash Lazy.t [@@deriving irmin ~pp_dump] + + type t = v ref + + let inspect t = !t + let of_key k = ref (Key k) + let of_hash h = ref (Hash h) + + let promote_exn t k = + let existing_hash = + match !t with + | Key k' -> + (* NOTE: it's valid for [k'] to not be strictly equal to [k], because + of duplicate objects in the store. In this case, we preferentially + take the newer key. *) + Key.to_hash k' + | Hash h -> Lazy.force h + in + if not (equal_hash existing_hash (Key.to_hash k)) then + Fmt.failwith + "Attempted to promote existing reference %a to an inconsistent key %a" + pp_dump_v !t pp_key k; + t := Key k + + let to_hash t = + match !t with Hash h -> Lazy.force h | Key k -> Key.to_hash k + + let is_key t = match !t with Key _ -> true | _ -> false + + let to_key_exn t = + match !t with + | Key k -> k + | Hash h -> + Fmt.failwith "Encountered unkeyed hash but expected key: %a" pp_hash + (Lazy.force h) + + let t = + let pre_hash_hash = Irmin.Type.(unstage (pre_hash hash_t)) in + let pre_hash x f = + match !x with + | Key k -> pre_hash_hash (Key.to_hash k) f + | Hash h -> pre_hash_hash (Lazy.force h) f + in + Irmin.Type.map ~pre_hash v_t (fun x -> ref x) (fun x -> !x) + end + + (* Binary representation. Used in two modes: + + - with [key]s as pointers to child values, when encoding values to add + to the underlying store (or decoding values read from the store) – + interoperable with the [Compress]-ed binary representation. + + - with either [key]s or [hash]es as pointers to child values, when + pre-computing the hash of a node with children that haven't yet been + written to the store. *) + module Bin = struct + open T + + (** Distinguishes between the two possible modes of binary value. *) + type _ mode = Ptr_key : key mode | Ptr_any : Val_ref.t mode + + type 'vref with_index = { index : int; vref : 'vref } [@@deriving irmin] + + type 'vref tree = { + depth : int; + length : int; + entries : 'vref with_index list; + } + [@@deriving irmin] + + type 'vref v = Values of (step * value) list | Tree of 'vref tree + [@@deriving irmin ~pre_hash] + + module V = + Irmin.Hash.Typed + (H) + (struct + type t = Val_ref.t v [@@deriving irmin] + end) + + type 'vref t = { hash : H.t Lazy.t; root : bool; v : 'vref v } + + let t : type vref. vref Irmin.Type.t -> vref t Irmin.Type.t = + fun vref_t -> + let open Irmin.Type in + let v_t = v_t vref_t in + let pre_hash_v = pre_hash_v vref_t in + let pre_hash x = pre_hash_v x.v in + record "Bin.t" (fun hash root v -> { hash = lazy hash; root; v }) + |+ field "hash" H.t (fun t -> Lazy.force t.hash) + |+ field "root" bool (fun t -> t.root) + |+ field "v" v_t (fun t -> t.v) + |> sealr + |> like ~pre_hash + + let v ~hash ~root v = { hash; root; v } + let hash t = Lazy.force t.hash + + let depth t = + match t.v with + | Values _ -> if t.root then Some 0 else None + | Tree t -> Some t.depth + end + + (* Compressed binary representation *) + module Compress = struct + open T + + type dict_key = int [@@deriving irmin] + type pack_offset = int63 [@@deriving irmin] + type name = Indirect of dict_key | Direct of step + type address = Offset of pack_offset | Hash of H.t [@@deriving irmin] + type ptr = { index : int; hash : address } + + let ptr_t : ptr Irmin.Type.t = + let open Irmin.Type in + record "Compress.ptr" (fun index hash -> { index; hash }) + |+ field "index" int (fun t -> t.index) + |+ field "hash" address_t (fun t -> t.hash) + |> sealr + + type tree = { depth : int; length : int; entries : ptr list } + + let tree_t : tree Irmin.Type.t = + let open Irmin.Type in + record "Compress.tree" (fun depth length entries -> + { depth; length; entries }) + |+ field "depth" int (fun t -> t.depth) + |+ field "length" int (fun t -> t.length) + |+ field "entries" (list ptr_t) (fun t -> t.entries) + |> sealr + + type value = + | Contents of name * address * metadata + | Node of name * address + + let is_default = T.(equal_metadata Metadata.default) + + (* We distribute products over sums in the type representation of [value] + in order to pack many possible cases into a single tag character in the + encoded representation. + + - whether the referenced value is a [Node] or a [Contents] value; + + - in the [Contents] case, whether the associated metadata is [default] + (in which case the serialised representation elides it), or if it is + included; + + - whether the [name] of the entry is provided inline [Direct], or is + stored in the dict and refernced via a dict key [Indirect]; + + - whether the [address] of the entry is a pack offset or a hash to be + indexed *) + let[@ocamlformat "disable"] value_t : value Irmin.Type.t = + let module Payload = struct + (* Different payload types that can appear after packed tags: *) + let io = [%typ: dict_key * pack_offset] + let ih = [%typ: dict_key * H.t] + let do_ = [%typ: step * pack_offset] + let dh = [%typ: step * H.t] + (* As above but for contents values with non-default metadata: *) + let x_io = [%typ: dict_key * pack_offset * metadata] + let x_ih = [%typ: dict_key * H.t * metadata] + let x_do = [%typ: step * pack_offset * metadata] + let x_dh = [%typ: step * H.t * metadata] + end in + let open Irmin.Type in + variant "Compress.value" + (fun + (* The ordering of these arguments determines which tags are assigned + to the cases, so should not be changed: *) + contents_io contents_x_io node_io contents_ih contents_x_ih node_ih + contents_do contents_x_do node_do contents_dh contents_x_dh node_dh + -> function + | Node (Indirect n, Offset o) -> node_io (n, o) + | Node (Indirect n, Hash h) -> node_ih (n, h) + | Node (Direct n, Offset o) -> node_do (n, o) + | Node (Direct n, Hash h) -> node_dh (n, h) + | Contents (Indirect n, Offset o, m) -> if is_default m then contents_io (n, o) else contents_x_io (n, o, m) + | Contents (Indirect n, Hash h, m) -> if is_default m then contents_ih (n, h) else contents_x_ih (n, h, m) + | Contents (Direct n, Offset o, m) -> if is_default m then contents_do (n, o) else contents_x_do (n, o, m) + | Contents (Direct n, Hash h, m) -> if is_default m then contents_dh (n, h) else contents_x_dh (n, h, m)) + |~ case1 "contents-io" Payload.io (fun (n, o) -> Contents (Indirect n, Offset o, Metadata.default)) + |~ case1 "contents-x-io" Payload.x_io (fun (n, i, m) -> Contents (Indirect n, Offset i, m)) + |~ case1 "node-io" Payload.io (fun (n, i) -> Node (Indirect n, Offset i)) + |~ case1 "contents-ih" Payload.ih (fun (n, h) -> Contents (Indirect n, Hash h, Metadata.default)) + |~ case1 "contents-x-ih" Payload.x_ih (fun (n, h, m) -> Contents (Indirect n, Hash h, m)) + |~ case1 "node-ih" Payload.ih (fun (n, h) -> Node (Indirect n, Hash h)) + |~ case1 "contents-do" Payload.do_ (fun (n, i) -> Contents (Direct n, Offset i, Metadata.default)) + |~ case1 "contents-x-do" Payload.x_do (fun (n, i, m) -> Contents (Direct n, Offset i, m)) + |~ case1 "node-do" Payload.do_ (fun (n, i) -> Node (Direct n, Offset i)) + |~ case1 "contents-dh" Payload.dh (fun (n, i) -> Contents (Direct n, Hash i, Metadata.default)) + |~ case1 "contents-x-dh" Payload.x_dh (fun (n, i, m) -> Contents (Direct n, Hash i, m)) + |~ case1 "node-dd" Payload.dh (fun (n, i) -> Node (Direct n, Hash i)) + |> sealv + + type v = Values of value list | Tree of tree + [@@deriving irmin ~encode_bin ~decode_bin ~size_of] + + let dynamic_size_of_v_encoding = + match Irmin.Type.Size.of_encoding v_t with + | Irmin.Type.Size.Dynamic f -> f + | _ -> assert false + + type kind = Pack_value.Kind.t + [@@deriving irmin ~encode_bin ~decode_bin ~size_of] + + type nonrec int = int [@@deriving irmin ~encode_bin ~decode_bin] + + let no_length = 0 + let is_real_length length = not (length = 0) + + type v1 = { mutable length : int; v : v } [@@deriving irmin] + (** [length] is the length of the binary encoding of [v]. It is not known + right away. [length] is [no_length] when it isn't known. Calling + [encode_bin] or [size_of] will make [length] known. *) + + (** [tagged_v] sits between [v] and [t]. It is a variant with the header + binary encoded as the magic. *) + type tagged_v = + | V0_stable of v + | V0_unstable of v + | V1_root of v1 + | V1_nonroot of v1 + [@@deriving irmin] + + let encode_bin_tv_staggered ({ v; _ } as tv) kind f = + (* We need to write [length] before [v], but we will know [length] + after [v] is encoded. The solution is to first encode [v], then write + [length] and then write [v]. *) + let l = ref [] in + encode_bin_v v (fun s -> l := s :: !l); + let length = List.fold_left (fun acc s -> acc + String.length s) 0 !l in + tv.length <- length; + encode_bin_kind kind f; + encode_bin_int length f; + List.iter f (List.rev !l) + + let encode_bin_tv tv f = + match tv with + | V0_stable _ -> assert false + | V0_unstable _ -> assert false + | V1_root { length; v } when is_real_length length -> + encode_bin_kind Pack_value.Kind.Inode_v2_root f; + encode_bin_int length f; + encode_bin_v v f + | V1_nonroot { length; v } when is_real_length length -> + encode_bin_kind Pack_value.Kind.Inode_v2_nonroot f; + encode_bin_int length f; + encode_bin_v v f + | V1_root tv -> encode_bin_tv_staggered tv Pack_value.Kind.Inode_v2_root f + | V1_nonroot tv -> + encode_bin_tv_staggered tv Pack_value.Kind.Inode_v2_nonroot f + + let decode_bin_tv s off = + let kind = decode_bin_kind s off in + match kind with + | Pack_value.Kind.Inode_v1_unstable -> + let v = decode_bin_v s off in + V0_unstable v + | Inode_v1_stable -> + let v = decode_bin_v s off in + V0_stable v + | Inode_v2_root -> + let length = decode_bin_int s off in + assert (is_real_length length); + let v = decode_bin_v s off in + V1_root { length; v } + | Inode_v2_nonroot -> + let length = decode_bin_int s off in + assert (is_real_length length); + let v = decode_bin_v s off in + V1_nonroot { length; v } + | Commit_v1 | Commit_v2 -> assert false + | Contents -> assert false + | Dangling_parent_commit -> assert false + + let size_of_tv = + let of_encoding s off = + let offref = ref off in + let kind = decode_bin_kind s offref in + match kind with + | Pack_value.Kind.Inode_v1_unstable | Inode_v1_stable -> + 1 + dynamic_size_of_v_encoding s !offref + | Inode_v2_root | Inode_v2_nonroot -> + let len = decode_bin_int s offref in + len - H.hash_size + | Commit_v1 | Commit_v2 | Contents -> assert false + | Dangling_parent_commit -> assert false + in + Irmin.Type.Size.custom_dynamic ~of_encoding () + + let tagged_v_t = + Irmin.Type.like ~bin:(encode_bin_tv, decode_bin_tv, size_of_tv) tagged_v_t + + type t = { hash : H.t; tv : tagged_v } + + let v ~root ~hash v = + let length = no_length in + let tv = + if root then V1_root { v; length } else V1_nonroot { v; length } + in + { hash; tv } + + (** The rule to determine the [is_root] property of a v0 [Value] is a bit + convoluted, it relies on the fact that back then the following property + was enforced: [Conf.stable_hash > Conf.entries]. + + When [t] is of tag [Values], then [t] is root iff [t] is stable. + + When [t] is stable, then [t] is a root, because: + + - Only 2 functions produce stable inodes: [stabilize] and [empty]. + - Only the roots are output of [stabilize]. + - An empty map can only be located at the root. + + When [t] is a root of tag [Value], then [t] is stable, because: + + - All the roots are output of [stabilize]. + - When an unstable inode enters [stabilize], it becomes stable if it has + at most [Conf.stable_hash] leaves. + - A [Value] has at most [Conf.stable_hash] leaves because + [Conf.entries <= Conf.stable_hash] is enforced. *) + let is_root = function + | { tv = V0_stable (Values _); _ } -> true + | { tv = V0_unstable (Values _); _ } -> false + | { tv = V0_stable (Tree { depth; _ }); _ } + | { tv = V0_unstable (Tree { depth; _ }); _ } -> + depth = 0 + | { tv = V1_root _; _ } -> true + | { tv = V1_nonroot _; _ } -> false + + let t = + let open Irmin.Type in + record "Compress.t" (fun hash tv -> { hash; tv }) + |+ field "hash" H.t (fun t -> t.hash) + |+ field "tagged_v" tagged_v_t (fun t -> t.tv) + |> sealr + end + + (** [Val_impl] defines the recursive structure of inodes. + + {3 Inode Layout} + + {4 Layout Types} + + The layout ['a layout] associated to an inode ['a t] defines certain + properties of the inode: + + - When [Total], the inode is self contained and immutable. + - When [Partial], chunks of the inode might be missing but they can be + fetched from the backend when needed using the available [find] function + stored in the layout. Mutable pointers act as cache. + - When [Truncated], chunks of the inode might be missing. Those chunks are + unreachable because the pointer to the backend is missing. The inode is + immutable. + + {4 Layout Instantiation} + + The layout of an inode is determined from the module [Val], it depends on + the way the inode was constructed: + + - When [Total], it originates from [Val.v] or [Val.empty]. + - When [Partial], it originates from [Val.of_bin], which is only used by + [Inode.find]. + - When [Truncated], it either originates from an [Irmin.Type] + deserialisation or from a proof. + + Almost all other functions in [Val_impl] are polymorphic regarding the + layout of the manipulated inode. + + {4 Details on the [Truncated] Layout} + + The [Truncated] layout is identical to [Partial] except for the missing + [find] function. + + On the one hand, when creating the root of a [Truncated] inode, the + pointers to children inodes - if any - are set to the [Broken] tag, + meaning that we know the hash to such children but we will have no way to + load them in the future. On the other hand, when adding child to a + [Truncated] inode, there is no such problem, the pointer is then set to + the [Intact] tag. + + A tree of inode only made of [Intact] tags is similar to a [Total] layout. + + As of Irmin 2.4 (February 2022), inode deserialisation using Repr happens + in [irmin/slice.ml] and [irmin/sync_ext.ml], and maybe some other places. + + At some point we might want to forbid such deserialisations and instead + use something in the flavour of [Val.of_bin] to create [Partial] inodes. + + {3 Topmost Inode Ancestor} + + [Val_impl.t] is a recursive type, it is labelled with a [depth] integer + that indicates the recursion depth. An inode with [depth = 0] corresponds + to the root of a directory, its hash is the hash of the directory. + + A [Val.t] points to the topmost [Val_impl.t] of an inode tree. In most + scenarios, that topmost inode has [depth = 0], but it is also legal for + the topmost inode to be an intermediate inode, i.e. with [depth > 0]. + + The only way for an inode tree to have an intermediate inode as root is to + fetch it from the backend by calling [Make_ext.find], using the hash of + that inode. + + Write-only operations are not permitted when the root is an intermediate + inode. *) + module Val_impl = struct + open T + + type _ layout = + | Total : total_ptr layout + | Partial : find -> partial_ptr layout + | Truncated : truncated_ptr layout + + and find = expected_depth:int -> key -> partial_ptr t option + + and partial_ptr_target = + | Dirty of partial_ptr t + | Lazy of key + | Lazy_loaded of partial_ptr t + (** A partial pointer differentiates the [Dirty] and [Lazy_loaded] + cases in order to remember that only the latter should be + collected when [clear] is called. + + The child in [Lazy_loaded] can only emanate from the disk. It can + be savely collected on [clear]. + + The child in [Dirty] can only emanate from a user modification, + e.g. through the [add] or [to_concrete] functions. It shouldn't be + collected on [clear] because it will be needed for [save]. *) + + and partial_ptr = { mutable target : partial_ptr_target } + and total_ptr = Total_ptr of total_ptr t [@@unboxed] + + and truncated_ptr = + | Broken of Val_ref.t + (** Initially [Hash.t], then set to [Key.t] when we try to save the + parent and successfully index the hash. *) + | Intact of truncated_ptr t + + and 'ptr tree = { depth : int; length : int; entries : 'ptr option array } + and 'ptr v = Values of value StepMap.t | Tree of 'ptr tree + + and 'ptr t = { + root : bool; + v : 'ptr v; + v_ref : Val_ref.t; + (** Represents what is known about [v]'s presence in a corresponding + store. Will be a [hash] if [v] is purely in-memory, and a [key] if + [v] has been written to / loaded from a store. *) + } + + module Ptr = struct + let val_ref : type ptr. ptr layout -> ptr -> Val_ref.t = function + | Total -> fun (Total_ptr ptr) -> ptr.v_ref + | Partial _ -> ( + fun { target } -> + match target with + | Lazy key -> Val_ref.of_key key + | Lazy_loaded { v_ref; _ } | Dirty { v_ref; _ } -> v_ref) + | Truncated -> ( function Broken v -> v | Intact ptr -> ptr.v_ref) + + let key_exn : type ptr. ptr layout -> ptr -> key = function + | Total -> fun (Total_ptr ptr) -> Val_ref.to_key_exn ptr.v_ref + | Partial _ -> ( + fun { target } -> + match target with + | Lazy key -> key + | Lazy_loaded { v_ref; _ } | Dirty { v_ref; _ } -> + Val_ref.to_key_exn v_ref) + | Truncated -> ( + function + | Broken h -> Val_ref.to_key_exn h + | Intact ptr -> Val_ref.to_key_exn ptr.v_ref) + + (** [force = false] will cause [target] to raise an exception when + encountering a tag [Lazy] inside a [Partial] inode. This feature is + used by [to_concrete] to make shallow the non-loaded inode branches. *) + let target : + type ptr. + expected_depth:int -> + cache:bool -> + force:bool -> + string -> + ptr layout -> + ptr -> + ptr t = + fun ~expected_depth ~cache ~force context layout -> + match layout with + | Total -> fun (Total_ptr t) -> t + | Partial find -> ( + function + | { target = Dirty entry } | { target = Lazy_loaded entry } -> + (* [target] is already cached. [cache] is only concerned with + new cache entries, not the older ones for which the irmin + users can discard using [clear]. *) + entry + | { target = Lazy key } as t -> ( + if not force then raise_dangling_hash context (Key.to_hash key); + match find ~expected_depth key with + | None -> Fmt.failwith "%a: unknown key" pp_key key + | Some x -> + if cache then t.target <- Lazy_loaded x; + x)) + | Truncated -> ( + function + | Intact entry -> entry + | Broken vref -> + let h = Val_ref.to_hash vref in + raise_dangling_hash context h) + + let of_target : type ptr. ptr layout -> ptr t -> ptr = function + | Total -> fun target -> Total_ptr target + | Partial _ -> fun target -> { target = Dirty target } + | Truncated -> fun target -> Intact target + + let of_key : type ptr. ptr layout -> key -> ptr = function + | Total -> assert false + | Partial _ -> fun key -> { target = Lazy key } + | Truncated -> fun key -> Broken (Val_ref.of_key key) + + type ('input, 'output) cps = { f : 'r. 'input -> ('output -> 'r) -> 'r } + [@@ocaml.unboxed] + + let save : + type ptr. + broken:(hash, key) cps -> + save_dirty:(ptr t, key) cps -> + clear:bool -> + ptr layout -> + ptr -> + unit = + fun ~broken ~save_dirty ~clear -> function + (* Invariant: after returning, we can recover the key from the saved + pointer (i.e. [key_exn] does not raise an exception). This is necessary + in order to be able to serialise a parent inode (for export) after + having saved its children. *) + | Total -> + fun (Total_ptr entry) -> + save_dirty.f entry (fun key -> + Val_ref.promote_exn entry.v_ref key) + | Partial _ -> ( + function + | { target = Dirty entry } as box -> + save_dirty.f entry (fun key -> + if clear then box.target <- Lazy key + else ( + box.target <- Lazy_loaded entry; + Val_ref.promote_exn entry.v_ref key)) + | { target = Lazy_loaded entry } as box -> + (* In this case, [entry.v_ref] is a [Hash h] such that [mem t + (index t h) = true]. We "save" the entry in order to trigger + the [index] lookup and recover the key, in order to meet the + return invariant above. + + TODO: refactor this case to be more precise. *) + save_dirty.f entry (fun key -> + if clear then box.target <- Lazy key) + | { target = Lazy _ } -> ()) + | Truncated -> ( + function + (* TODO: this branch is currently untested: we never attempt to + save a truncated node as part of the unit tests. *) + | Intact entry -> + save_dirty.f entry (fun key -> + Val_ref.promote_exn entry.v_ref key) + | Broken vref -> + if not (Val_ref.is_key vref) then + broken.f (Val_ref.to_hash vref) (fun key -> + Val_ref.promote_exn vref key)) + + let clear : + type ptr. + iter_dirty:(ptr layout -> ptr t -> unit) -> ptr layout -> ptr -> unit + = + fun ~iter_dirty layout ptr -> + match layout with + | Partial _ -> ( + match ptr with + | { target = Lazy _ } -> () + | { target = Dirty ptr } -> iter_dirty layout ptr + | { target = Lazy_loaded ptr } as box -> + (* Since a [Lazy_loaded] used to be a [Lazy], the key is always + available. *) + let key = Val_ref.to_key_exn ptr.v_ref in + box.target <- Lazy key) + | Total | Truncated -> () + end + + let pred layout t = + match t.v with + | Tree i -> + let key_of_ptr = Ptr.key_exn layout in + Array.fold_left + (fun acc -> function + | None -> acc + | Some ptr -> (None, `Inode (key_of_ptr ptr)) :: acc) + [] i.entries + | Values l -> + StepMap.fold + (fun s v acc -> + let v = + match v with + | `Node _ as k -> (Some s, k) + | `Contents (k, _) -> (Some s, `Contents k) + in + v :: acc) + l [] + + let length_of_v = function + | Values vs -> StepMap.cardinal vs + | Tree vs -> vs.length + + let length t = length_of_v t.v + + let rec clear layout t = + match t.v with + | Tree i -> + Array.iter + (Option.iter (Ptr.clear ~iter_dirty:clear layout)) + i.entries + | Values _ -> () + + let nb_children t = + match t.v with + | Tree i -> + Array.fold_left + (fun i -> function None -> i | Some _ -> i + 1) + 0 i.entries + | Values vs -> StepMap.cardinal vs + + type cont = off:int -> len:int -> (step * value) Seq.node + + let rec seq_tree layout bucket_seq ~depth ~cache : cont -> cont = + fun k ~off ~len -> + assert (off >= 0); + assert (len > 0); + match bucket_seq () with + | Seq.Nil -> k ~off ~len + | Seq.Cons (None, rest) -> seq_tree layout rest ~depth ~cache k ~off ~len + | Seq.Cons (Some i, rest) -> + let trg = + let expected_depth = depth + 1 in + Ptr.target ~expected_depth ~cache ~force:true "seq_tree" layout i + in + let trg_len = length trg in + if off - trg_len >= 0 then + (* Skip a branch of the inode tree in case the user asked for a + specific starting offset. + + Without this branch the algorithm would keep the same semantic + because [seq_value] would handles the pagination value by value + instead. *) + let off = off - trg_len in + seq_tree layout rest ~depth ~cache k ~off ~len + else + seq_v layout trg.v ~cache + (seq_tree layout rest ~depth ~cache k) + ~off ~len + + and seq_values layout value_seq : cont -> cont = + fun k ~off ~len -> + assert (off >= 0); + assert (len > 0); + match value_seq () with + | Seq.Nil -> k ~off ~len + | Cons (x, rest) -> + if off = 0 then + let len = len - 1 in + if len = 0 then + (* Yield the current value and skip the rest of the inode tree in + case the user asked for a specific length. *) + Seq.Cons (x, Seq.empty) + else Seq.Cons (x, fun () -> seq_values layout rest k ~off ~len) + else + (* Skip one value in case the user asked for a specific starting + offset. *) + let off = off - 1 in + seq_values layout rest k ~off ~len + + and seq_v layout v ~cache : cont -> cont = + fun k ~off ~len -> + assert (off >= 0); + assert (len > 0); + match v with + | Tree t -> + let depth = t.depth in + seq_tree layout (Array.to_seq t.entries) ~depth ~cache k ~off ~len + | Values vs -> seq_values layout (StepMap.to_seq vs) k ~off ~len + + let empty_continuation : cont = fun ~off:_ ~len:_ -> Seq.Nil + + let seq layout ?offset:(off = 0) ?length:(len = Int.max_int) ?(cache = true) + t : (step * value) Seq.t = + if off < 0 then invalid_arg "Invalid pagination offset"; + if len < 0 then invalid_arg "Invalid pagination length"; + if len = 0 then Seq.empty + else fun () -> seq_v layout t.v ~cache empty_continuation ~off ~len + + let seq_tree layout ?(cache = true) i : (step * value) Seq.t = + let off = 0 in + let len = Int.max_int in + fun () -> seq_v layout (Tree i) ~cache empty_continuation ~off ~len + + let seq_v layout ?(cache = true) v : (step * value) Seq.t = + let off = 0 in + let len = Int.max_int in + fun () -> seq_v layout v ~cache empty_continuation ~off ~len + + let to_bin_v : + type ptr vref. ptr layout -> vref Bin.mode -> ptr v -> vref Bin.v = + fun layout mode node -> + Stats.incr_inode_to_binv (); + match node with + | Values vs -> + let vs = StepMap.bindings vs in + Bin.Values vs + | Tree t -> + let vref_of_ptr : ptr -> vref = + match mode with + | Bin.Ptr_any -> Ptr.val_ref layout + | Bin.Ptr_key -> Ptr.key_exn layout + in + let _, entries = + Array.fold_left + (fun (i, acc) -> function + | None -> (i + 1, acc) + | Some ptr -> + let vref = vref_of_ptr ptr in + (i + 1, { Bin.index = i; vref } :: acc)) + (0, []) t.entries + in + let entries = List.rev entries in + Bin.Tree { depth = t.depth; length = t.length; entries } + + let is_root t = t.root + let is_stable t = should_be_stable ~length:(length t) ~root:(is_root t) + + let to_bin layout mode t = + let v = to_bin_v layout mode t.v in + Bin.v ~root:(is_root t) ~hash:(lazy (Val_ref.to_hash t.v_ref)) v + + type len = [ `Eq of int | `Ge of int ] [@@deriving irmin] + + module Concrete = struct + type kinded_key = + | Contents of contents_key + | Contents_x of metadata * contents_key + | Node of node_key + [@@deriving irmin] + + type entry = { name : step; key : kinded_key } [@@deriving irmin] + + type 'a pointer = { index : int; pointer : hash; tree : 'a } + [@@deriving irmin] + + type 'a tree = { depth : int; length : int; pointers : 'a pointer list } + [@@deriving irmin] + + type t = Tree of t tree | Values of entry list | Blinded + [@@deriving irmin] + + let to_entry (name, v) = + match v with + | `Contents (contents_key, m) -> + if T.equal_metadata m Metadata.default then + { name; key = Contents contents_key } + else { name; key = Contents_x (m, contents_key) } + | `Node node_key -> { name; key = Node node_key } + + let of_entry e = + ( e.name, + match e.key with + | Contents key -> `Contents (key, Metadata.default) + | Contents_x (m, key) -> `Contents (key, m) + | Node key -> `Node key ) + + type error = + [ `Invalid_hash of hash * hash * t + | `Invalid_depth of int * int * t + | `Invalid_length of len * int * t + | `Duplicated_entries of t + | `Duplicated_pointers of t + | `Unsorted_entries of t + | `Unsorted_pointers of t + | `Blinded_root + | `Too_large_values of t + | `Empty ] + [@@deriving irmin] + + let rec length = function + | Values l -> `Eq (List.length l) + | Tree t -> + List.fold_left + (fun acc p -> + match (acc, length p.tree) with + | `Eq x, `Eq y -> `Eq (x + y) + | (`Eq x | `Ge x), (`Eq y | `Ge y) -> `Ge (x + y)) + (`Eq 0) t.pointers + | Blinded -> `Ge 0 + + let pp = Irmin.Type.pp_json t + + let pp_len ppf = function + | `Eq e -> Fmt.pf ppf "%d" e + | `Ge e -> Fmt.pf ppf "'at least %d'" e + + let pp_error ppf = function + | `Invalid_hash (got, expected, t) -> + Fmt.pf ppf "invalid hash for %a@,got: %a@,expecting: %a" pp t + pp_hash got pp_hash expected + | `Invalid_depth (got, expected, t) -> + Fmt.pf ppf "invalid depth for %a@,got: %d@,expecting: %d" pp t got + expected + | `Invalid_length (got, expected, t) -> + Fmt.pf ppf "invalid length for %a@,got: %a@,expecting: %d" pp t + pp_len got expected + | `Duplicated_entries t -> Fmt.pf ppf "duplicated entries: %a" pp t + | `Duplicated_pointers t -> Fmt.pf ppf "duplicated pointers: %a" pp t + | `Unsorted_entries t -> Fmt.pf ppf "entries should be sorted: %a" pp t + | `Unsorted_pointers t -> + Fmt.pf ppf "pointers should be sorted: %a" pp t + | `Blinded_root -> Fmt.pf ppf "blinded root" + | `Too_large_values t -> + Fmt.pf ppf "A Values should have at most Conf.entries elements: %a" + pp t + | `Empty -> Fmt.pf ppf "concrete subtrees cannot be empty" + end + + let to_concrete ~force (la : 'ptr layout) (t : 'ptr t) = + let rec aux t = + let h = Val_ref.to_hash t.v_ref in + match t.v with + | Tree tr -> + ( h, + Concrete.Tree + { + depth = tr.depth; + length = tr.length; + pointers = + Array.fold_left + (fun (i, acc) e -> + match e with + | None -> (i + 1, acc) + | Some t -> + let expected_depth = tr.depth + 1 in + let pointer, tree = + try + aux + (Ptr.target ~expected_depth ~cache:true ~force + "to_concrete" la t) + with Dangling_hash { hash; _ } -> + (hash, Concrete.Blinded) + in + (i + 1, { Concrete.index = i; tree; pointer } :: acc)) + (0, []) tr.entries + |> snd + |> List.rev; + } ) + | Values l -> + ( h, + Concrete.Values (List.map Concrete.to_entry (StepMap.bindings l)) + ) + in + snd (aux t) + + exception Invalid_hash of hash * hash * Concrete.t + exception Invalid_depth of int * int * Concrete.t + exception Invalid_length of len * int * Concrete.t + exception Empty + exception Duplicated_entries of Concrete.t + exception Duplicated_pointers of Concrete.t + exception Unsorted_entries of Concrete.t + exception Unsorted_pointers of Concrete.t + exception Blinded_root + exception Too_large_values of Concrete.t + + let hash_equal = Irmin.Type.(unstage (equal hash_t)) + + let of_concrete_exn : type a. depth:int -> a layout -> _ -> a t = + fun ~depth la t -> + let sort_entries = + List.sort_uniq (fun x y -> compare x.Concrete.name y.Concrete.name) + in + let sort_pointers = + List.sort_uniq (fun x y -> compare x.Concrete.index y.Concrete.index) + in + let check_entries t es = + if es = [] then raise Empty; + let s = sort_entries es in + if List.compare_length_with es Conf.entries > 0 then + raise (Too_large_values t); + if List.compare_lengths s es <> 0 then raise (Duplicated_entries t); + if s <> es then raise (Unsorted_entries t) + in + let check_pointers t ps = + if ps = [] then raise Empty; + let s = sort_pointers ps in + if List.length s <> List.length ps then raise (Duplicated_pointers t); + if s <> ps then raise (Unsorted_pointers t) + in + let hash v = Bin.V.hash (to_bin_v la Bin.Ptr_any v) in + let rec aux depth t = + match t with + | Concrete.Blinded -> None + | Concrete.Values l -> + check_entries t l; + Some (Values (StepMap.of_list (List.map Concrete.of_entry l))) + | Concrete.Tree tr -> + let entries = Array.make Conf.entries None in + check_pointers t tr.pointers; + List.iter + (fun { Concrete.index; pointer; tree } -> + match aux (depth + 1) tree with + | None -> + (* Child is blinded *) + let ptr = + match la with + | Total -> assert false + | Partial _ -> + (* [of_concrete_exn (Partial _)] is only used in the + context of portable inodes, [unfindable_of_hash] is + fine. *) + let k = Key.unfindable_of_hash pointer in + Ptr.of_key la k + | Truncated -> + let v_ref = Val_ref.of_hash (lazy pointer) in + (Broken v_ref : a) + in + entries.(index) <- Some ptr + | Some v -> + let hash = hash v in + if not (hash_equal hash pointer) then + raise (Invalid_hash (hash, pointer, t)); + let v_ref = Val_ref.of_hash (lazy pointer) in + let t = { v_ref; root = false; v } in + entries.(index) <- Some (Ptr.of_target la t)) + tr.pointers; + if depth <> tr.depth then raise (Invalid_depth (depth, tr.depth, t)); + let () = + match Concrete.length t with + | `Eq length -> + if length <> tr.length then + raise (Invalid_length (`Eq length, tr.length, t)) + | `Ge length -> + if length > tr.length then + raise (Invalid_length (`Ge length, tr.length, t)) + in + + Some (Tree { depth = tr.depth; length = tr.length; entries }) + in + let v = + match aux depth t with None -> raise Blinded_root | Some v -> v + in + let length = length_of_v v in + let hash = + (* Compute the hash right away (not lazily) so that + [hash_exn ~force:false] is possible on the result of + [of_proof]. *) + if should_be_stable ~length ~root:(depth = 0) then + (* [seq_v] may call [find], even if some branches are blinded *) + let node = Node.of_seq (seq_v la v) in + Node.hash node + else hash v + in + { v_ref = Val_ref.of_hash (Lazy.from_val hash); root = depth = 0; v } + + let of_concrete ~depth la t = + try Ok (of_concrete_exn ~depth la t) with + | Invalid_hash (x, y, z) -> Error (`Invalid_hash (x, y, z)) + | Invalid_depth (x, y, z) -> Error (`Invalid_depth (x, y, z)) + | Invalid_length (x, y, z) -> Error (`Invalid_length (x, y, z)) + | Empty -> Error `Empty + | Duplicated_entries t -> Error (`Duplicated_entries t) + | Duplicated_pointers t -> Error (`Duplicated_pointers t) + | Unsorted_entries t -> Error (`Unsorted_entries t) + | Unsorted_pointers t -> Error (`Unsorted_pointers t) + | Too_large_values t -> Error (`Too_large_values t) + | Blinded_root -> Error `Blinded_root + + let hash t = Val_ref.to_hash t.v_ref + + let hash_exn ?(force = true) t = + match Val_ref.inspect t.v_ref with + | Key k -> Key.to_hash k + | Hash h -> + if Lazy.is_val h || force then Lazy.force h else raise Not_found + + let check_write_op_supported t = + if not @@ is_root t then + failwith "Cannot perform operation on non-root inode value." + + let stabilize_root layout t = + let n = length t in + (* If [t] is the empty inode (i.e. [n = 0]) then is is already stable *) + if n > Conf.stable_hash then { t with root = true } + else + let v_ref = + Val_ref.of_hash + (lazy + (let vs = seq layout t in + Node.hash (Node.of_seq vs))) + in + { v_ref; v = t.v; root = true } + + let index ~depth k = + if depth >= max_depth then raise (Max_depth depth); + Child_ordering.index ~depth k + + (** This function shouldn't be called with the [Total] layout. In the + future, we could add a polymorphic variant to the GADT parameter to + enfoce that. *) + let of_bin layout (t : key Bin.t) = + let v = + match t.Bin.v with + | Bin.Values vs -> + let vs = StepMap.of_list vs in + Values vs + | Tree t -> + let entries = Array.make Conf.entries None in + let ptr_of_key = Ptr.of_key layout in + List.iter + (fun { Bin.index; vref } -> + entries.(index) <- Some (ptr_of_key vref)) + t.entries; + Tree { depth = t.Bin.depth; length = t.length; entries } + in + { v_ref = Val_ref.of_hash t.Bin.hash; root = t.Bin.root; v } + + let empty : 'a. 'a layout -> 'a t = + fun _ -> + let v_ref = Val_ref.of_hash (lazy (Node.hash (Node.empty ()))) in + { root = false; v_ref; v = Values StepMap.empty } + + let values layout vs = + let length = StepMap.cardinal vs in + if length = 0 then empty layout + else + let v = Values vs in + let v_ref = + Val_ref.of_hash (lazy (Bin.V.hash (to_bin_v layout Bin.Ptr_any v))) + in + { v_ref; root = false; v } + + let tree layout is = + let v = Tree is in + let v_ref = + Val_ref.of_hash (lazy (Bin.V.hash (to_bin_v layout Bin.Ptr_any v))) + in + { v_ref; root = false; v } + + let is_empty t = + match t.v with Values vs -> StepMap.is_empty vs | Tree _ -> false + + let find_value ~cache layout t s = + let key = Child_ordering.key s in + let rec aux = function + | Values vs -> ( try Some (StepMap.find s vs) with Not_found -> None) + | Tree t -> ( + let i = index ~depth:t.depth key in + let x = t.entries.(i) in + match x with + | None -> None + | Some i -> + let expected_depth = t.depth + 1 in + aux + (Ptr.target ~expected_depth ~cache ~force:true "find_value" + layout i) + .v) + in + aux t.v + + let find ?(cache = true) layout t s = find_value ~cache layout t s + + let rec add layout ~depth ~copy ~replace parent s key v k = + Stats.incr_inode_rec_add (); + match parent.v with + | Values vs -> + let length = + if replace then StepMap.cardinal vs else StepMap.cardinal vs + 1 + in + let parent = + if length <= Conf.entries then values layout (StepMap.add s v vs) + else + let vs = StepMap.bindings (StepMap.add s v vs) in + let empty = + tree layout + { length = 0; depth; entries = Array.make Conf.entries None } + in + let aux t (s', v) = + let key' = Child_ordering.key s' in + (add [@tailcall]) layout ~depth ~copy:false ~replace t s' key' v + (fun x -> x) + in + List.fold_left aux empty vs + in + k parent + | Tree tr -> ( + assert (depth = tr.depth); + let length = if replace then tr.length else tr.length + 1 in + let entries = if copy then Array.copy tr.entries else tr.entries in + let i = index ~depth key in + match entries.(i) with + | None -> + let child = values layout (StepMap.singleton s v) in + entries.(i) <- Some (Ptr.of_target layout child); + let parent = tree layout { tr with length; entries } in + k parent + | Some ptr -> + let child = + let expected_depth = depth + 1 in + (* [cache] is unimportant here as we've already called + [find_value] for that path.*) + Ptr.target ~expected_depth ~cache:true ~force:true "add" layout + ptr + in + (add [@tailcall]) layout ~depth:(depth + 1) ~copy ~replace child s + key v (fun child -> + entries.(i) <- Some (Ptr.of_target layout child); + let parent = tree layout { tr with length; entries } in + k parent)) + + let add layout ~copy t s v = + let k = Child_ordering.key s in + match find_value ~cache:true layout t s with + | Some v' when equal_value v v' -> t + | Some _ -> + add ~depth:0 layout ~copy ~replace:true t s k v Fun.id + |> stabilize_root layout + | None -> + add ~depth:0 layout ~copy ~replace:false t s k v Fun.id + |> stabilize_root layout + + let rec remove layout parent s key k = + Stats.incr_inode_rec_remove (); + match parent.v with + | Values vs -> + let parent = values layout (StepMap.remove s vs) in + k parent + | Tree tr -> ( + let depth = tr.depth in + let len = tr.length - 1 in + if len <= Conf.entries then + let vs = seq_tree layout tr in + let vs = StepMap.of_seq vs in + let vs = StepMap.remove s vs in + let parent = values layout vs in + k parent + else + let entries = Array.copy tr.entries in + let i = index ~depth key in + match entries.(i) with + | None -> assert false + | Some ptr -> + let child = + let expected_depth = depth + 1 in + (* [cache] is unimportant here as we've already called + [find_value] for that path.*) + Ptr.target ~expected_depth ~cache:true ~force:true "remove" + layout ptr + in + if length child = 1 then ( + entries.(i) <- None; + let parent = tree layout { depth; length = len; entries } in + k parent) + else + (remove [@tailcall]) layout child s key (fun child -> + entries.(i) <- Some (Ptr.of_target layout child); + let parent = + tree layout { tr with length = len; entries } + in + k parent)) + + let remove layout t s = + let k = Child_ordering.key s in + match find_value ~cache:true layout t s with + | None -> t + | Some _ -> remove layout t s k Fun.id |> stabilize_root layout + + let of_seq la l = + let t = + let rec aux_big seq inode = + match seq () with + | Seq.Nil -> inode + | Seq.Cons ((s, v), rest) -> + aux_big rest (add la ~copy:false inode s v) + in + let len = + (* [StepMap.cardinal] is (a bit) expensive to compute, let's track the + size of the map in a [ref] while doing [StepMap.update]. *) + ref 0 + in + let rec aux_small seq map = + match seq () with + | Seq.Nil -> + assert (!len <= Conf.entries); + values la map + | Seq.Cons ((s, v), rest) -> + let map = + StepMap.update s + (function + | None -> + incr len; + Some v + | Some _ -> Some v) + map + in + if !len = Conf.entries then aux_big rest (values la map) + else aux_small rest map + in + aux_small l StepMap.empty + in + stabilize_root la t + + let save layout ~add ~index ~mem t = + let clear = + (* When set to [true], collect the loaded inodes as soon as they're + saved. + + This parameter is not exposed yet. Ideally it would be exposed and + be forwarded from [Tree.export ?clear] through [P.Node.add]. + + It is currently set to false in order to preserve behaviour *) + false + in + let iter_entries = + let broken h k = + (* This function is called when we encounter a Broken pointer with + Truncated layouts. *) + match index h with + | None -> + Fmt.failwith + "You are trying to save to the backend an inode deserialized \ + using [Irmin.Type] that used to contain pointer(s) to inodes \ + which are unknown to the backend. Hash: %a" + pp_hash h + | Some key -> + (* The backend already knows this target inode, there is no need to + traverse further down. This happens during the unit tests. *) + k key + in + fun ~save_dirty arr -> + let iter_ptr = + Ptr.save ~broken:{ f = broken } ~save_dirty ~clear layout + in + Array.iter (Option.iter iter_ptr) arr + in + let rec aux ~depth t = + [%log.debug "save depth:%d" depth]; + match t.v with + | Values _ -> ( + let unguarded_add hash = + let value = + (* NOTE: the choice of [Bin.mode] is irrelevant (and this + conversion is always safe), since nodes of kind [Values _] + contain no internal pointers. *) + to_bin layout Bin.Ptr_key t + in + let key = add hash value in + Val_ref.promote_exn t.v_ref key; + key + in + match Val_ref.inspect t.v_ref with + | Key key -> + if mem key then key else unguarded_add (Key.to_hash key) + | Hash hash -> unguarded_add (Lazy.force hash)) + | Tree n -> + let save_dirty t k = + let key = + match Val_ref.inspect t.v_ref with + | Key key -> if mem key then key else aux ~depth:(depth + 1) t + | Hash hash -> ( + match index (Lazy.force hash) with + | Some key -> + if mem key then key + else + (* In this case, [index] has returned a key that is + not present in the underlying store. This is + permitted by the contract on index functions (and + required by [irmin-pack.mem]), but never happens + with the persistent {!Pack_store} backend (provided + the store is not corrupted). *) + aux ~depth:(depth + 1) t + | None -> aux ~depth:(depth + 1) t) + in + Val_ref.promote_exn t.v_ref key; + k key + in + iter_entries ~save_dirty:{ f = save_dirty } n.entries; + let bin = + (* Serialising with [Bin.Ptr_key] is safe here because just called + [Ptr.save] on any dirty children (and we never try to save + [Portable] nodes). *) + to_bin layout Bin.Ptr_key t + in + let key = add (Val_ref.to_hash t.v_ref) bin in + Val_ref.promote_exn t.v_ref key; + key + in + aux ~depth:0 t + + let check_stable layout t = + let rec check t any_stable_ancestor = + let stable = is_stable t || any_stable_ancestor in + match t.v with + | Values _ -> true + | Tree tree -> + Array.for_all + (function + | None -> true + | Some t -> + let t = + let expected_depth = tree.depth + 1 in + Ptr.target ~expected_depth ~cache:true ~force:true + "check_stable" layout t + in + (if stable then not (is_stable t) else true) + && check t stable) + tree.entries + in + check t (is_stable t) + + let contains_empty_map layout t = + let rec check_lower t = + match t.v with + | Values l when StepMap.is_empty l -> true + | Values _ -> false + | Tree inodes -> + Array.exists + (function + | None -> false + | Some t -> + let expected_depth = inodes.depth + 1 in + Ptr.target ~expected_depth ~cache:true ~force:true + "contains_empty_map" layout t + |> check_lower) + inodes.entries + in + check_lower t + + let is_tree t = match t.v with Tree _ -> true | Values _ -> false + + module Proof = struct + type value = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + + type t = + [ `Blinded of hash + | `Values of (step * value) list + | `Inode of int * (int * t) list ] + [@@deriving irmin] + + let weaken_step_value (step, v) = (step, hashvalue_of_keyvalue v) + + let strengthen_step_value (step, v) = + (* Since proofs are used only in the context of portable, using this + unsafe function is safe. *) + (step, unsafe_keyvalue_of_hashvalue v) + + let rec proof_of_concrete : + type a. hash Lazy.t -> Concrete.t -> (t -> a) -> a = + fun h concrete k -> + match concrete with + | Blinded -> k (`Blinded (Lazy.force h)) + | Values vs -> + let l = + List.map Concrete.of_entry vs |> List.map weaken_step_value + in + k (`Values l) + | Tree tr -> + let proofs = + List.fold_left + (fun acc (e : _ Concrete.pointer) -> + let hash = lazy e.pointer in + proof_of_concrete hash e.tree (fun proof -> + (e.index, proof) :: acc)) + [] (List.rev tr.pointers) + in + k (`Inode (tr.length, proofs)) + + let hash_values ~depth l = + let inode = values Truncated (StepMap.of_list l) in + let t = + match depth with 0 -> { inode with root = true } | _ -> inode + in + hash t + + let hash_inode ~depth ~length es = + let entries = Array.make Conf.entries None in + List.iter (fun (index, ptr) -> entries.(index) <- Some ptr) es; + let v : truncated_ptr v = Tree { depth; length; entries } in + Bin.V.hash (to_bin_v Truncated Bin.Ptr_any v) + + let rec concrete_of_proof : + type a. depth:int -> t -> (hash -> Concrete.t -> a) -> a = + fun ~depth proof k -> + match proof with + | `Blinded h -> k h Concrete.Blinded + | `Values vs -> + let vs = List.map strengthen_step_value vs in + assert (List.compare_length_with vs Conf.entries <= 0); + let hash = hash_values ~depth vs in + let c = Concrete.Values (List.map Concrete.to_entry vs) in + k hash c + | `Inode (length, proofs) -> concrete_of_inode ~length ~depth proofs k + + and concrete_of_inode : + type a. + length:int -> + depth:int -> + (int * t) list -> + (hash -> Concrete.t -> a) -> + a = + fun ~length ~depth proofs k -> + let rec aux ps es = function + | [] -> + let c = Concrete.Tree { depth; length; pointers = ps } in + let hash = hash_inode ~depth ~length es in + k hash c + | (index, proof) :: proofs -> + concrete_of_proof ~depth:(depth + 1) proof (fun pointer tree -> + let ps = { Concrete.tree; pointer; index } :: ps in + let h = Val_ref.of_hash (lazy pointer) in + let es = (index, Broken h) :: es in + aux ps es proofs) + in + aux [] [] (List.rev proofs) + + let proof_of_concrete h p = proof_of_concrete h p Fun.id + let concrete_of_proof ~depth p = concrete_of_proof ~depth p (fun _ t -> t) + + let to_proof la t : t = + let p = + if is_stable t then + (* To preserve the stable hash, the proof needs to contain + all the underlying values. *) + let bindings = + seq la t + |> Seq.map Concrete.to_entry + |> List.of_seq + |> List.fast_sort (fun x y -> + compare_step x.Concrete.name y.Concrete.name) + in + Concrete.Values bindings + else to_concrete ~force:false la t + in + proof_of_concrete (lazy (Val_ref.to_hash t.v_ref)) p + + let of_proof (Partial _ as la) ~depth (proof : t) = + match proof with + | `Values vs when List.compare_length_with vs Conf.entries > 0 -> ( + if depth <> 0 then None + else + (* [proof] is a big stable inode that was unshallowed and encoded + in a [Values], it needs to be converted back to a [Tree] + shallowed. *) + let t = + of_seq Total (List.map strengthen_step_value vs |> List.to_seq) + in + let hash = + (* Compute the hash right away (not lazily) so that + [hash_exn ~force:false] is possible on the result of + [of_proof]. *) + hash t + in + let v_ref = Val_ref.of_hash (Lazy.from_val hash) in + match t.v with + | Values _ -> assert false + | Tree { depth; length; entries } -> + let ptr_of_key = Ptr.of_key la in + let entries = + Array.map + (function + | None -> None + | Some ptr -> + let hash = + Ptr.val_ref Total ptr |> Val_ref.to_hash + in + (* Since [of_proof] is only called in the context of + Portable inodes, [unfindable_of_hash] is safe. *) + let key = Key.unfindable_of_hash hash in + Some (ptr_of_key key)) + entries + in + let v = Tree { depth; length; entries } in + let t = { v_ref; v; root = true } in + Some t) + | _ -> ( + let c = concrete_of_proof ~depth proof in + match of_concrete la ~depth c with + | Ok v -> Some v + | Error _ -> None) + + let of_concrete t = proof_of_concrete (lazy (failwith "blinded root")) t + let to_concrete = concrete_of_proof ~depth:0 + end + + module Snapshot = struct + include T + + type kinded_hash = Contents of hash * metadata | Node of hash + [@@deriving irmin] + + type entry = { step : string; hash : kinded_hash } [@@deriving irmin] + + type inode_tree = { + depth : int; + length : int; + pointers : (int * hash) list; + } + [@@deriving irmin] + + type v = Inode_tree of inode_tree | Inode_value of entry list + [@@deriving irmin] + + type inode = { v : v; root : bool } [@@deriving irmin] + end + + let of_entry ~index e : step * Node.value = + let step = + match T.step_of_bin_string e.Snapshot.step with + | Ok s -> s + | Error (`Msg m) -> Fmt.failwith "step of bin error: %s" m + in + ( step, + match e.hash with + | Snapshot.Contents (hash, m) -> + let key = index hash in + `Contents (key, m) + | Node hash -> + let key = index hash in + `Node key ) + + let of_inode_tree ~index layout tr = + let entries = Array.make Conf.entries None in + let ptr_of_key hash = + let key = index hash in + Ptr.of_key layout key + in + List.iter + (fun (index, pointer) -> entries.(index) <- Some (ptr_of_key pointer)) + tr.Snapshot.pointers; + { depth = tr.depth; length = tr.length; entries } + + let of_snapshot ~index layout (v : Snapshot.inode) = + let t = + match v.v with + | Inode_value vs -> + values layout (StepMap.of_list (List.map (of_entry ~index) vs)) + | Inode_tree tr -> tree layout (of_inode_tree ~index layout tr) + in + if v.root then stabilize_root layout t else t + end + + module Raw = struct + type hash = H.t [@@deriving irmin] + type key = Key.t + type t = T.key Bin.t [@@deriving irmin] + type metadata = T.metadata [@@deriving irmin] + + let depth = Bin.depth + + exception Invalid_depth of { expected : int; got : int; v : t } + + let kind (t : t) = + (* This is the kind of newly appended values, let's use v1 then *) + if t.root then Pack_value.Kind.Inode_v2_root + else Pack_value.Kind.Inode_v2_nonroot + + let hash t = Bin.hash t + let step_to_bin = T.step_to_bin_string + let step_of_bin = T.step_of_bin_string + let encode_compress = Irmin.Type.(unstage (encode_bin Compress.t)) + let decode_compress = Irmin.Type.(unstage (decode_bin Compress.t)) + + let length_header = function + | Pack_value.Kind.Contents -> + (* NOTE: the Node instantiation of the pack store must have access to + the header format used by contents values in order to eagerly + construct contents keys with length information during + [key_of_offset]. *) + Conf.contents_length_header + | k -> Pack_value.Kind.length_header_exn k + + let decode_compress_length = + match Irmin.Type.Size.of_encoding Compress.t with + | Unknown | Static _ -> assert false + | Dynamic f -> f + + let encode_bin : + dict:(string -> int option) -> + offset_of_key:(Key.t -> int63 option) -> + hash -> + t Irmin.Type.encode_bin = + fun ~dict ~offset_of_key hash t -> + Stats.incr_inode_encode_bin (); + let step s : Compress.name = + let str = step_to_bin s in + if String.length str <= 3 then Direct s + else match dict str with Some i -> Indirect i | None -> Direct s + in + let address_of_key key : Compress.address = + match offset_of_key key with + | Some off -> Compress.Offset off + | None -> + (* The key references an inode/contents that is not in the pack + file. This is highly unusual but not forbidden. *) + Compress.Hash (Key.to_hash key) + in + let ptr : T.key Bin.with_index -> Compress.ptr = + fun n -> + let hash = address_of_key n.vref in + { index = n.index; hash } + in + let value : T.step * T.value -> Compress.value = function + | s, `Contents (c, m) -> + let s = step s in + let v = address_of_key c in + Compress.Contents (s, v, m) + | s, `Node n -> + let s = step s in + let v = address_of_key n in + Compress.Node (s, v) + in + (* List.map is fine here as the number of entries is small *) + let v : T.key Bin.v -> Compress.v = function + | Values vs -> Values (List.map value vs) + | Tree { depth; length; entries } -> + let entries = List.map ptr entries in + Tree { Compress.depth; length; entries } + in + let t = Compress.v ~root:t.root ~hash (v t.v) in + encode_compress t + + exception Exit of [ `Msg of string ] + + let decode_bin : + dict:(int -> string option) -> + key_of_offset:(int63 -> key) -> + key_of_hash:(hash -> key) -> + t Irmin.Type.decode_bin = + fun ~dict ~key_of_offset ~key_of_hash t pos_ref -> + Stats.incr_inode_decode_bin (); + let i = decode_compress t pos_ref in + let step : Compress.name -> T.step = function + | Direct n -> n + | Indirect s -> ( + match dict s with + | None -> raise_notrace (Exit (`Msg "dict")) + | Some s -> ( + match step_of_bin s with + | Error e -> raise_notrace (Exit e) + | Ok v -> v)) + in + let key : Compress.address -> T.key = function + | Offset off -> key_of_offset off + | Hash n -> key_of_hash n + in + let ptr : Compress.ptr -> T.key Bin.with_index = + fun n -> + let vref = key n.hash in + { index = n.index; vref } + in + let value : Compress.value -> T.step * T.value = function + | Contents (n, h, metadata) -> + let name = step n in + let hash = key h in + (name, `Contents (hash, metadata)) + | Node (n, h) -> + let name = step n in + let hash = key h in + (name, `Node hash) + in + let t : Compress.tagged_v -> T.key Bin.v = + fun tv -> + let v = + match tv with + | V0_stable v -> v + | V0_unstable v -> v + | V1_root { v; _ } -> v + | V1_nonroot { v; _ } -> v + in + match v with + | Values vs -> Values (List.rev_map value (List.rev vs)) + | Tree { depth; length; entries } -> + let entries = List.map ptr entries in + Tree { depth; length; entries } + in + let root = Compress.is_root i in + let v = t i.tv in + Bin.v ~root ~hash:(lazy i.hash) v + + let decode_bin_length = decode_compress_length + + let decode_children_offsets ~entry_of_offset ~entry_of_hash t pos_ref = + let i = decode_compress t pos_ref in + let { Compress.tv; _ } = i in + let v = + match tv with + | V0_stable v | V0_unstable v -> v + | V1_root { v; _ } | V1_nonroot { v; _ } -> v + in + let entry_of_address = function + | Compress.Offset offset -> entry_of_offset offset + | Hash h -> entry_of_hash h + in + match v with + | Values ls -> + List.map + (function + | Compress.Contents (_, address, _) | Node (_, address) -> + entry_of_address address) + ls + | Tree { entries; _ } -> + List.map + (function ({ hash; _ } : Compress.ptr) -> entry_of_address hash) + entries + + module Snapshot = Val_impl.Snapshot + + let to_entry : T.step * Node.value -> Snapshot.entry = + fun (name, v) -> + let step = step_to_bin name in + match v with + | `Contents (contents_key, m) -> + let h = Key.to_hash contents_key in + { Snapshot.step; hash = Contents (h, m) } + | `Node node_key -> + let h = Key.to_hash node_key in + { step; hash = Node h } + + (* The implementation of [of_snapshot] is in the module [Val]. This is + because we cannot compute the hash of a root from [Bin]. *) + let to_snapshot : t -> Snapshot.inode = + fun t -> + match t.v with + | Bin.Tree tree -> + let inode_tree = + { + Snapshot.depth = tree.depth; + length = tree.length; + pointers = + List.map + (fun { Bin.index; vref } -> + let hash = Key.to_hash vref in + (index, hash)) + tree.entries; + } + in + { v = Inode_tree inode_tree; root = t.root } + | Values vs -> + let vs = List.map to_entry vs in + let v = Snapshot.Inode_value vs in + { v; root = t.root } + end + + module Snapshot = Val_impl.Snapshot + + let to_snapshot = Raw.to_snapshot + + type hash = T.hash + type key = Key.t + + let pp_hash = T.pp_hash + + module Val_portable = struct + include T + module I = Val_impl + + type t = + | Total of I.total_ptr I.t + | Partial of I.partial_ptr I.layout * I.partial_ptr I.t + | Truncated of I.truncated_ptr I.t + + type 'b apply_fn = { f : 'a. 'a I.layout -> 'a I.t -> 'b } [@@unboxed] + + let apply : t -> 'b apply_fn -> 'b = + fun t f -> + match t with + | Total v -> f.f I.Total v + | Partial (layout, v) -> f.f layout v + | Truncated v -> f.f I.Truncated v + + type map_fn = { f : 'a. 'a I.layout -> 'a I.t -> 'a I.t } [@@unboxed] + + let map : t -> map_fn -> t = + fun t f -> + match t with + | Total v -> + let v' = f.f I.Total v in + if v == v' then t else Total v' + | Partial (layout, v) -> + let v' = f.f layout v in + if v == v' then t else Partial (layout, v') + | Truncated v -> + let v' = f.f I.Truncated v in + if v == v' then t else Truncated v' + + let pred t = apply t { f = (fun layout v -> I.pred layout v) } + + let of_seq l = + Stats.incr_inode_of_seq (); + Total (I.of_seq Total l) + + let of_list l = of_seq (List.to_seq l) + + let seq ?offset ?length ?cache t = + apply t { f = (fun layout v -> I.seq layout ?offset ?length ?cache v) } + + let list ?offset ?length ?cache t = + List.of_seq (seq ?offset ?length ?cache t) + + let empty () = of_list [] + let is_empty t = apply t { f = (fun _ v -> I.is_empty v) } + + let find ?cache t s = + apply t { f = (fun layout v -> I.find ?cache layout v s) } + + let add t s value = + Stats.incr_inode_add (); + let f layout v = + I.check_write_op_supported v; + I.add ~copy:true layout v s value + in + map t { f } + + let remove t s = + Stats.incr_inode_remove (); + let f layout v = + I.check_write_op_supported v; + I.remove layout v s + in + map t { f } + + let t : t Irmin.Type.t = + let pre_hash_binv = Irmin.Type.(unstage (pre_hash (Bin.v_t Val_ref.t))) in + let pre_hash_node = Irmin.Type.(unstage (pre_hash Node.t)) in + let pre_hash x = + let stable = apply x { f = (fun _ v -> I.is_stable v) } in + if not stable then + let bin = + apply x { f = (fun layout v -> I.to_bin layout Bin.Ptr_any v) } + in + pre_hash_binv bin.v + else + let vs = + (* If [x] is shallow, this [seq] call will perform IOs. *) + seq x + in + pre_hash_node (Node.of_seq vs) + in + let module Ptr_any = struct + let t = + Irmin.Type.map (Bin.t Val_ref.t) + (fun _ -> assert false) + (fun x -> + apply x { f = (fun layout v -> I.to_bin layout Bin.Ptr_any v) }) + + type nonrec t = t [@@deriving irmin ~equal ~compare ~pp] + + (* TODO(repr): add these to [ppx_repr] meta-deriving *) + (* TODO(repr): why is there no easy way to get a decoder value to pass to [map ~json]? *) + let encode_json = Irmin.Type.encode_json t + let decode_json _ = failwith "TODO" + end in + Irmin.Type.map ~pre_hash ~pp:Ptr_any.pp + ~json:(Ptr_any.encode_json, Ptr_any.decode_json) + ~equal:Ptr_any.equal ~compare:Ptr_any.compare (Bin.t T.key_t) + (fun bin -> Truncated (I.of_bin I.Truncated bin)) + (fun x -> + apply x { f = (fun layout v -> I.to_bin layout Bin.Ptr_key v) }) + + let hash_exn ?force t = apply t { f = (fun _ v -> I.hash_exn ?force v) } + + let save ?(allow_non_root = false) ~add ~index ~mem t = + if Conf.forbid_empty_dir_persistence && is_empty t then + failwith + "Persisting an empty node is forbidden by the configuration of the \ + irmin-pack store"; + let f layout v = + if not allow_non_root then I.check_write_op_supported v; + I.save layout ~add ~index ~mem v + in + apply t { f } + + let of_raw (find' : expected_depth:int -> key -> key Bin.t option) v = + Stats.incr_inode_of_raw (); + let rec find ~expected_depth h = + Option.map (I.of_bin layout) (find' ~expected_depth h) + and layout = I.Partial find in + Partial (layout, I.of_bin layout v) + + let to_raw t = + apply t { f = (fun layout v -> I.to_bin layout Bin.Ptr_key v) } + + let stable t = apply t { f = (fun _ v -> I.is_stable v) } + let length t = apply t { f = (fun _ v -> I.length v) } + let clear t = apply t { f = (fun layout v -> I.clear layout v) } + let nb_children t = apply t { f = (fun _ v -> I.nb_children v) } + let index ~depth s = I.index ~depth (Child_ordering.key s) + + let integrity_check t = + let f layout v = + let check_stable () = + let check () = I.check_stable layout v in + let n = length t in + if n > Conf.stable_hash then (not (stable t)) && check () + else stable t && check () + in + let contains_empty_map_non_root () = + let check () = I.contains_empty_map layout v in + (* we are only looking for empty maps that are not at the root *) + if I.is_tree v then check () else false + in + check_stable () && not (contains_empty_map_non_root ()) + in + apply t { f } + + let merge ~contents ~node : t Irmin.Merge.t = + let merge = Node.merge ~contents ~node in + let to_node t = of_seq (Node.seq t) in + let of_node n = Node.of_seq (seq n) in + Irmin.Merge.like t merge of_node to_node + + let with_handler f_env t = + match t with + | Total _ -> t + | Truncated _ -> t + | Partial ((I.Partial find as la), v) -> + (* [f_env] works on [Val.t] while [find] in [Partial find] works on + [Val_impl.t], hence the following wrapping (before applying + [f_env]) and unwrapping (after [f_env]). *) + let find_v ~expected_depth h = + match find ~expected_depth h with + | None -> None + | Some v -> Some (Partial (la, v)) + in + let find = f_env find_v in + let find_ptr ~expected_depth h = + match find ~expected_depth h with + | Some (Partial (_, v)) -> Some v + | _ -> None + in + let la = I.Partial find_ptr in + Partial (la, v) + + let head t = + let f la (v : _ I.t) = + if Val_impl.is_stable v then + (* To preserve the stable hash, the proof needs to contain + all the underlying values. *) + let elts = + I.seq la v + |> List.of_seq + |> List.fast_sort (fun (x, _) (y, _) -> compare_step x y) + in + `Node elts + else + match v.v with + | I.Values n -> `Node (List.of_seq (StepMap.to_seq n)) + | I.Tree v -> + let entries = ref [] in + for i = Array.length v.entries - 1 downto 0 do + match v.entries.(i) with + | None -> () + | Some ptr -> + let h = I.Ptr.val_ref la ptr |> Val_ref.to_hash in + entries := (i, h) :: !entries + done; + `Inode (v.length, !entries) + in + apply t { f } + end + + module Val = struct + include Val_portable + + module Portable = struct + include Val_portable + + type node_key = hash [@@deriving irmin] + type contents_key = hash [@@deriving irmin] + + type value = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + + let of_node t = t + + let of_list bindings = + bindings + |> List.map (fun (k, v) -> (k, unsafe_keyvalue_of_hashvalue v)) + |> of_list + + let of_seq bindings = + bindings + |> Seq.map (fun (k, v) -> (k, unsafe_keyvalue_of_hashvalue v)) + |> of_seq + + let seq ?offset ?length ?cache t = + seq ?offset ?length ?cache t + |> Seq.map (fun (k, v) -> (k, hashvalue_of_keyvalue v)) + + let add : t -> step -> value -> t = + fun t s v -> add t s (unsafe_keyvalue_of_hashvalue v) + + let list ?offset ?length ?cache t = + list ?offset ?length ?cache t + |> List.map (fun (s, v) -> (s, hashvalue_of_keyvalue v)) + + let find ?cache t s = find ?cache t s |> Option.map hashvalue_of_keyvalue + + let merge = + let promote_merge : + hash option Irmin.Merge.t -> key option Irmin.Merge.t = + fun t -> + Irmin.Merge.like [%typ: key option] t (Option.map Key.to_hash) + (Option.map Key.unfindable_of_hash) + in + fun ~contents ~node -> + merge ~contents:(promote_merge contents) ~node:(promote_merge node) + + module Proof = I.Proof + + type proof = I.Proof.t [@@deriving irmin] + + let to_proof (t : t) : proof = + apply t { f = (fun la v -> I.Proof.to_proof la v) } + + let of_proof ~depth (p : proof) = + let find ~expected_depth:_ k = + raise_dangling_hash "of_proof@find" (Key.to_hash k) + in + (* A [Partial] should be built instead of a [Truncated] because we need a + [find] function that will be hooked by the proof env and that will + raise the above exception in case of miss in the env. *) + let la = I.Partial find in + Option.map (fun v -> Partial (la, v)) (I.Proof.of_proof la ~depth p) + + type 'a find = expected_depth:int -> 'a -> t option + + let with_handler : (hash find -> hash find) -> t -> t = + let to_hash : key find -> hash find = + fun find ~expected_depth h -> + find ~expected_depth (Key.unfindable_of_hash h) + in + let to_key : hash find -> key find = + fun find ~expected_depth k -> find ~expected_depth (Key.to_hash k) + in + fun f_env t -> + with_handler (fun find -> find |> to_hash |> f_env |> to_key) t + + let head t = + match head t with + | `Inode _ as x -> x + | `Node l -> `Node (List.map Proof.weaken_step_value l) + end + + let to_concrete t = + apply t { f = (fun la v -> I.to_concrete ~force:true la v) } + + let of_concrete t = + match I.of_concrete Truncated ~depth:0 t with + | Ok t -> Ok (Truncated t) + | Error _ as e -> e + + module Snapshot = I.Snapshot + module Concrete = I.Concrete + + let of_snapshot t ~index find' = + let rec find ~expected_depth h = + match find' ~expected_depth h with + | None -> None + | Some v -> Some (I.of_bin layout v) + and layout = I.Partial find in + Partial (layout, I.of_snapshot layout t ~index) + end +end + +module Make + (H : Irmin.Hash.S) + (Key : Irmin.Key.S with type hash = H.t) + (Node : Irmin.Node.Generic_key.S + with type hash = H.t + and type contents_key = Key.t + and type node_key = Key.t) + (Inter : Internal + with type hash = H.t + and type key = Key.t + and type Snapshot.metadata = Node.metadata + and type Val.step = Node.step) + (Pack : Indexable.S + with type hash = H.t + and type key = Key.t + and type value = Inter.Raw.t) = +struct + module Hash = H + module Key = Key + module Val = Inter.Val + + type 'a t = 'a Pack.t + type key = Key.t [@@deriving irmin ~equal] + type hash = Hash.t + type value = Inter.Val.t + + let mem t k = Pack.mem t k + let index t k = Pack.index t k + + exception Invalid_depth = Inter.Raw.Invalid_depth + + let pp_value = Irmin.Type.pp Inter.Raw.t + + let pp_invalid_depth ppf (expected, got, v) = + Fmt.pf ppf "Invalid depth: got %d, expecting %d (%a)" got expected pp_value + v + + let check_depth_opt ~expected_depth:expected = function + | None -> () + | Some v -> ( + match Inter.Raw.depth v with + | None -> () + | Some got -> + if got <> expected then raise (Invalid_depth { expected; got; v })) + + let unsafe_find ~check_integrity t k = + match Pack.unsafe_find ~check_integrity t k with + | None -> None + | Some v -> + let find ~expected_depth k = + let v = Pack.unsafe_find ~check_integrity t k in + check_depth_opt ~expected_depth v; + v + in + let v = Val.of_raw find v in + Some v + + let find t k = unsafe_find ~check_integrity:true t k |> Lwt.return + + let save ?allow_non_root t v = + let add k v = + Pack.unsafe_append ~ensure_unique:true ~overcommit:false t k v + in + Val.save ?allow_non_root ~add ~index:(Pack.index_direct t) + ~mem:(Pack.unsafe_mem t) v + + let hash_exn = Val.hash_exn + let add t v = Lwt.return (save t v) + let equal_hash = Irmin.Type.(unstage (equal H.t)) + + let check_hash expected got = + if equal_hash expected got then () + else + Fmt.invalid_arg "corrupted value: got %a, expecting %a" Inter.pp_hash + expected Inter.pp_hash got + + let unsafe_add t k v = + check_hash k (hash_exn v); + Lwt.return (save t v) + + let batch = Pack.batch + let close = Pack.close + let decode_bin_length = Inter.Raw.decode_bin_length + + let protect_from_invalid_depth_exn f = + Lwt.catch f (function + | Invalid_depth { expected; got; v } -> + let msg = Fmt.to_to_string pp_invalid_depth (expected, got, v) in + Lwt.return (Error msg) + | e -> Lwt.fail e) + + let integrity_check_inodes t k = + protect_from_invalid_depth_exn @@ fun () -> + find t k >|= function + | None -> + (* we are traversing the node graph, should find all values *) + assert false + | Some v -> + if Inter.Val.integrity_check v then Ok () + else + let msg = + Fmt.str "Problematic inode %a" (Irmin.Type.pp Inter.Val.t) v + in + Error msg +end diff --git a/vendors/irmin/src/irmin-pack/inode.mli b/vendors/irmin/src/irmin-pack/inode.mli new file mode 100644 index 0000000000000000000000000000000000000000..ec0d0630854211e2808e94c748a2584c8552ad64 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/inode.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Inode_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/inode_intf.ml b/vendors/irmin/src/irmin-pack/inode_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..ed5b3c34188a4121cc2e270e7d806757d43035f8 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/inode_intf.ml @@ -0,0 +1,265 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type Child_ordering = sig + type step + type key + + val key : step -> key + val index : depth:int -> key -> int +end + +module type Snapshot = sig + type hash + type metadata + + type kinded_hash = Contents of hash * metadata | Node of hash + [@@deriving irmin] + + type entry = { step : string; hash : kinded_hash } [@@deriving irmin] + + type inode_tree = { depth : int; length : int; pointers : (int * hash) list } + [@@deriving irmin] + + type v = Inode_tree of inode_tree | Inode_value of entry list + [@@deriving irmin] + + type inode = { v : v; root : bool } [@@deriving irmin] +end + +module type Value = sig + type key + + include + Irmin.Node.Generic_key.S + with type node_key = key + and type contents_key = key + + val pred : + t -> + (step option + * [ `Node of node_key | `Inode of node_key | `Contents of contents_key ]) + list + + module Portable : + Irmin.Node.Portable.S + with type node := t + and type hash = hash + and type step := step + and type metadata := metadata + + val nb_children : t -> int +end + +module type Raw = sig + include Pack_value.S + + val depth : t -> int option + + exception Invalid_depth of { expected : int; got : int; v : t } + + val decode_children_offsets : + entry_of_offset:(int63 -> 'a) -> + entry_of_hash:(hash -> 'a) -> + string -> + int ref -> + 'a list +end + +module type S = sig + include Irmin.Indexable.S + module Hash : Irmin.Hash.S with type t = hash + + val unsafe_find : check_integrity:bool -> [< read ] t -> key -> value option + + module Val : + Value + with type t = value + and type key = key + and type hash = Hash.t + and type Portable.hash := hash + + val decode_bin_length : string -> int -> int + val integrity_check_inodes : [ `Read ] t -> key -> (unit, string) result Lwt.t + val save : ?allow_non_root:bool -> 'a t -> value -> key +end + +(** Unstable internal API agnostic about the underlying storage. Use it only to + implement or test inodes. *) +module type Internal = sig + type hash + type key + + val pp_hash : hash Fmt.t + + module Snapshot : Snapshot with type hash = hash + module Raw : Raw with type hash = hash and type key = key + + module Val : sig + include + Value + with type hash = hash + and type key = key + and type metadata = Snapshot.metadata + + val of_raw : (expected_depth:int -> key -> Raw.t option) -> Raw.t -> t + val to_raw : t -> Raw.t + + val save : + ?allow_non_root:bool -> + add:(hash -> Raw.t -> key) -> + index:(hash -> key option) -> + mem:(key -> bool) -> + t -> + key + + val stable : t -> bool + val length : t -> int + val index : depth:int -> step -> int + + val integrity_check : t -> bool + (** Checks the integrity of an inode. *) + + module Concrete : sig + (** {1 Concrete trees} *) + + (** The type for pointer kinds. *) + type kinded_key = + | Contents of contents_key + | Contents_x of metadata * contents_key + | Node of node_key + [@@deriving irmin] + + type entry = { name : step; key : kinded_key } [@@deriving irmin] + (** The type of entries. *) + + type 'a pointer = { index : int; pointer : hash; tree : 'a } + [@@deriving irmin] + (** The type for internal pointers between concrete {!tree}s. *) + + type 'a tree = { depth : int; length : int; pointers : 'a pointer list } + [@@deriving irmin] + (** The type for trees. *) + + (** The type for concrete trees. *) + type t = Tree of t tree | Values of entry list | Blinded + [@@deriving irmin] + + type len := [ `Eq of int | `Ge of int ] + + type error = + [ `Invalid_hash of hash * hash * t + | `Invalid_depth of int * int * t + | `Invalid_length of len * int * t + | `Duplicated_entries of t + | `Duplicated_pointers of t + | `Unsorted_entries of t + | `Unsorted_pointers of t + | `Blinded_root + | `Too_large_values of t + | `Empty ] + [@@deriving irmin] + (** The type for errors. *) + + val pp_error : error Fmt.t + (** [pp_error] is the pretty-printer for errors. *) + end + + val to_concrete : t -> Concrete.t + (** [to_concrete t] is the concrete inode tree equivalent to [t]. *) + + val of_concrete : Concrete.t -> (t, Concrete.error) result + (** [of_concrete c] is [Ok t] iff [c] and [t] are equivalent. + + The result is [Error e] when a subtree tree of [c] has an integrity + error. *) + + module Portable : sig + (* Extend to the portable signature *) + include module type of Portable + + module Proof : sig + val of_concrete : Concrete.t -> proof + + val to_concrete : proof -> Concrete.t + (** This function produces unfindable keys. Only use in tests *) + end + end + + val of_snapshot : + Snapshot.inode -> + index:(hash -> key) -> + (expected_depth:int -> key -> Raw.t option) -> + t + end + + val to_snapshot : Raw.t -> Snapshot.inode + + module Child_ordering : Child_ordering with type step := Val.step +end + +module type Sigs = sig + module type S = S + module type Internal = Internal + module type Child_ordering = Child_ordering + module type Raw = Raw + module type Snapshot = Snapshot + + exception Max_depth of int + + module Make_internal + (Conf : Conf.S) + (H : Irmin.Hash.S) (Key : sig + include Irmin.Key.S with type hash = H.t + + val unfindable_of_hash : hash -> t + end) + (Node : Irmin.Node.Generic_key.S + with type hash = H.t + and type contents_key = Key.t + and type node_key = Key.t) : + Internal + with type hash = H.t + and type key = Key.t + and type Snapshot.metadata = Node.metadata + and type Val.step = Node.step + + module Make + (H : Irmin.Hash.S) + (Key : Irmin.Key.S with type hash = H.t) + (Node : Irmin.Node.Generic_key.S + with type hash = H.t + and type contents_key = Key.t + and type node_key = Key.t) + (Inter : Internal + with type hash = H.t + and type key = Key.t + and type Snapshot.metadata = Node.metadata + and type Val.step = Node.step) + (Pack : Indexable.S + with type key = Key.t + and type hash = H.t + and type value = Inter.Raw.t) : + S + with type 'a t = 'a Pack.t + and type key = Key.t + and type hash = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step + and type value = Inter.Val.t +end diff --git a/vendors/irmin/src/irmin-pack/irmin_pack.ml b/vendors/irmin/src/irmin-pack/irmin_pack.ml new file mode 100644 index 0000000000000000000000000000000000000000..ab774fd9214642a0b5b10dad48ec03a8558a0b8d --- /dev/null +++ b/vendors/irmin/src/irmin-pack/irmin_pack.ml @@ -0,0 +1,36 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin_pack_intf + +let config = Conf.init + +exception RO_not_allowed = S.RO_not_allowed + +module Indexing_strategy = Indexing_strategy +module Indexable = Indexable +module Atomic_write = Atomic_write +module Hash = Irmin.Hash.BLAKE2B +module Path = Irmin.Path.String_list +module Metadata = Irmin.Metadata.None +module Version = Version +module Conf = Conf +module Stats = Stats +module Layout = Layout +module Inode = Inode +module Pack_key = Pack_key +module Pack_value = Pack_value +module S = S diff --git a/vendors/irmin/src/irmin-pack/irmin_pack.mli b/vendors/irmin/src/irmin-pack/irmin_pack.mli new file mode 100644 index 0000000000000000000000000000000000000000..621f0967c91a18a26f645c9a5f3eee89eddde230 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/irmin_pack.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin_pack_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/irmin_pack_intf.ml b/vendors/irmin/src/irmin-pack/irmin_pack_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..7c22fd6acd9f1f18ca53af91429b70382bd6abd4 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/irmin_pack_intf.ml @@ -0,0 +1,70 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = S.S +module type Specifics = S.Specifics +module type Maker = S.Maker +module type Maker_persistent = S.Maker_persistent + +module type Sigs = sig + module Conf = Conf + module Indexing_strategy = Indexing_strategy + module Inode = Inode + module Pack_key = Pack_key + module Pack_value = Pack_value + + val config : + ?fresh:bool -> + ?readonly:bool -> + ?lru_size:int -> + ?index_log_size:int -> + ?merge_throttle:Conf.merge_throttle -> + ?indexing_strategy:Indexing_strategy.t -> + ?use_fsync:bool -> + ?dict_auto_flush_threshold:int -> + ?suffix_auto_flush_threshold:int -> + ?no_migrate:bool -> + string -> + Irmin.config + (** Configuration options for stores. + + @param fresh whether an existing store should be overwritten. + @param read_only whether read-only mode is enabled for this store. + @param lru_size the maximum number of bindings in the lru cache. + @param index_log_size the maximum number of bindings in the index cache. + @param index_throttle + the strategy to use when the index cache is full and an async + [Index.merge] in already in progress. [Block_writes] (the default) + blocks any new writes until the merge is completed. [Overcommit_memory] + does not block but indefinitely expands the in-memory cache. + @param indexing_strategy + The {{!Indexing_strategy} indexing strategy} of the backend store. + Defaults to {!Indexing_strategy.default}. *) + + exception RO_not_allowed + + module type S = S + module type Specifics = Specifics + module type Maker = Maker + module type Maker_persistent = Maker_persistent + + module Stats = Stats + module Layout = Layout + module Indexable = Indexable + module Atomic_write = Atomic_write + module Version = Version + module S = S +end diff --git a/vendors/irmin/src/irmin-pack/layout.ml b/vendors/irmin/src/irmin-pack/layout.ml new file mode 100644 index 0000000000000000000000000000000000000000..5c4aa8ce9a4df2d2c7999235b7d4aebe52ff7524 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/layout.ml @@ -0,0 +1,51 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let toplevel name ~root = Filename.(concat root name) + +module V1_and_v2 = struct + let pack = toplevel "store.pack" + let branch = toplevel "store.branches" + let dict = toplevel "store.dict" + let all ~root = [ pack ~root; branch ~root; dict ~root ] +end + +module V3 = struct + let branch = toplevel "store.branches" + let dict = toplevel "store.dict" + let control = toplevel "store.control" + + let suffix ~generation = + toplevel ("store." ^ string_of_int generation ^ ".suffix") + + let gc_result ~generation = + toplevel ("store." ^ string_of_int generation ^ ".out") + + let reachable ~generation = + toplevel ("store." ^ string_of_int generation ^ ".reachable") + + let sorted ~generation = + toplevel ("store." ^ string_of_int generation ^ ".sorted") + + let mapping ~generation = + toplevel ("store." ^ string_of_int generation ^ ".mapping") + + let prefix ~generation = + toplevel ("store." ^ string_of_int generation ^ ".prefix") + + let all ~generation ~root = + [ suffix ~generation ~root; branch ~root; dict ~root; control ~root ] +end diff --git a/vendors/irmin/src/irmin-pack/mem/dune b/vendors/irmin/src/irmin-pack/mem/dune new file mode 100644 index 0000000000000000000000000000000000000000..98d92099149135f428ec1700f6a8c3653fae0fa9 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/mem/dune @@ -0,0 +1,8 @@ +(library + (public_name irmin-pack.mem) + (name irmin_pack_mem) + (libraries irmin-pack irmin.mem) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-pack/mem/import.ml b/vendors/irmin/src/irmin-pack/mem/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..d4aa41686a2eb2ae04f5fb717120dfedd1b921bc --- /dev/null +++ b/vendors/irmin/src/irmin-pack/mem/import.ml @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends +module Int63 = Optint.Int63 + +let src = Logs.Src.create "irmin-pack.mem" ~doc:"irmin-pack mem backend" + +module Log = (val Logs.src_log src : Logs.LOG) + +type int63 = Int63.t diff --git a/vendors/irmin/src/irmin-pack/mem/indexable.ml b/vendors/irmin/src/irmin-pack/mem/indexable.ml new file mode 100644 index 0000000000000000000000000000000000000000..840e5e82686c40532b70acfb403c7a9978d6cff0 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/mem/indexable.ml @@ -0,0 +1,135 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module Pool : sig + type ('k, 'v) t + (** Reference-counted pool of values with corresponding keys. *) + + val create : alloc:('k -> 'v) -> ('k, 'v) t + (** Get an empty pool, given a function for allocating new instances from IDs. *) + + val take : ('k, 'v) t -> 'k -> 'v + (** Get an instance from the pool by its key, allocating it if necessary. *) + + val drop : ('k, 'v) t -> 'k -> unit + (** Reduce the reference count of an element, discarding it if the reference + count drops to 0. *) +end = struct + type 'v elt = { mutable refcount : int; instance : 'v } + type ('k, 'v) t = { instances : ('k, 'v elt) Hashtbl.t; alloc : 'k -> 'v } + + let create ~alloc = { instances = Hashtbl.create 0; alloc } + + let take t k = + match Hashtbl.find_opt t.instances k with + | Some elt -> + elt.refcount <- succ elt.refcount; + elt.instance + | None -> + let instance = t.alloc k in + Hashtbl.add t.instances k { instance; refcount = 1 }; + instance + + let drop t k = + match Hashtbl.find_opt t.instances k with + | None -> failwith "Pool.drop: double free" + | Some { refcount; _ } when refcount <= 0 -> assert false + | Some { refcount = 1; _ } -> Hashtbl.remove t.instances k + | Some elt -> elt.refcount <- pred elt.refcount +end + +module Maker (K : Irmin.Hash.S) = struct + type key = K.t + + module Make + (Val : Irmin_pack.Pack_value.S with type hash := K.t and type key := K.t) = + struct + (* TODO(craigfe): We could use the keys to skip traversal of the map on + lookup. This wasn't done originally due to complications with implementing + the [clear] function, but this has since been removed. (See #1794.) *) + module Key = Irmin.Key.Of_hash (K) + + module KMap = Map.Make (struct + type t = K.t + + let compare = Irmin.Type.(unstage (compare K.t)) + end) + + type hash = K.t + type key = Key.t + type value = Val.t + type 'a t = { name : string; mutable t : value KMap.t } + + let index_direct _ h = Some h + let index t h = Lwt.return (index_direct t h) + let instances = Pool.create ~alloc:(fun name -> { name; t = KMap.empty }) + let v name = Lwt.return (Pool.take instances name) + let equal_key = Irmin.Type.(unstage (equal K.t)) + + let close t = + [%log.debug "close"]; + Pool.drop instances t.name; + Lwt.return_unit + + let cast t = (t :> read_write t) + let batch t f = f (cast t) + let pp_hash = Irmin.Type.pp K.t + + let check_key k v = + let k' = Val.hash v in + if equal_key k k' then Ok () else Error (k, k') + + let find t k = + try + let v = KMap.find k t.t in + check_key k v |> Result.map (fun () -> Some v) + with Not_found -> Ok None + + let unsafe_find ~check_integrity:_ t k = + [%log.debug "unsafe find %a" pp_hash k]; + find t k |> function + | Ok r -> r + | Error (k, k') -> + Fmt.invalid_arg "corrupted value: got %a, expecting %a" pp_hash k' + pp_hash k + + let find t k = + [%log.debug "find %a" pp_hash k]; + find t k |> function + | Ok r -> Lwt.return r + | Error (k, k') -> + Fmt.kstr Lwt.fail_invalid_arg "corrupted value: got %a, expecting %a" + pp_hash k' pp_hash k + + let unsafe_mem t k = + [%log.debug "mem %a" pp_hash k]; + KMap.mem k t.t + + let mem t k = Lwt.return (unsafe_mem t k) + + let unsafe_append ~ensure_unique:_ ~overcommit:_ t k v = + [%log.debug "add -> %a" pp_hash k]; + t.t <- KMap.add k v t.t; + k + + let unsafe_add t k v = + Lwt.return (unsafe_append ~ensure_unique:true ~overcommit:true t k v) + + let add t v = unsafe_add t (Val.hash v) v + end +end diff --git a/vendors/irmin/src/irmin-pack/mem/indexable.mli b/vendors/irmin/src/irmin-pack/mem/indexable.mli new file mode 100644 index 0000000000000000000000000000000000000000..20ac827fc30fc5b1a4982640d2eb567cc8b79380 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/mem/indexable.mli @@ -0,0 +1,31 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) +open! Import + +module Maker (K : Irmin.Hash.S) : sig + type key = K.t + + module Make + (Val : Irmin_pack.Pack_value.S with type hash := K.t and type key := K.t) : sig + include + Irmin_pack.Indexable.S + with type hash = K.t + and type key = K.t + and type value = Val.t + + val v : string -> read t Lwt.t + end +end diff --git a/vendors/irmin/src/irmin-pack/mem/irmin_pack_mem.ml b/vendors/irmin/src/irmin-pack/mem/irmin_pack_mem.ml new file mode 100644 index 0000000000000000000000000000000000000000..dba0cfc136c1a39ba10812e662b99308b530a3d9 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/mem/irmin_pack_mem.ml @@ -0,0 +1,213 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct + module AW = Irmin_mem.Atomic_write (K) (V) + include AW + + let v () = AW.v (Irmin_mem.config ()) + let flush _t = () +end + +module Indexable_mem + (Hash : Irmin.Hash.S) + (Value : Irmin_pack.Pack_value.S + with type hash := Hash.t + and type key = Hash.t) = +struct + module Pack = Indexable.Maker (Hash) + module Indexable_mem = Pack.Make (Value) + include Irmin_pack.Indexable.Closeable (Indexable_mem) + + let v x = Indexable_mem.v x >|= make_closeable +end + +module Maker (Config : Irmin_pack.Conf.S) = struct + type endpoint = unit + + include Irmin.Key.Store_spec.Hash_keyed + + module Make (Schema : Irmin.Schema.Extended) = struct + module H = Schema.Hash + module C = Schema.Contents + module P = Schema.Path + module M = Schema.Metadata + module B = Schema.Branch + module Pack = Indexable.Maker (H) + + module XKey = struct + include Irmin.Key.Of_hash (H) + + let unfindable_of_hash x = x + end + + module X = struct + module Schema = Schema + module Hash = H + module Info = Schema.Info + + module Contents = struct + module Pack_value = + Irmin_pack.Pack_value.Of_contents (Config) (H) (XKey) (C) + + module Indexable = Indexable_mem (H) (Pack_value) + include Irmin.Contents.Store_indexable (Indexable) (H) (C) + end + + module Node = struct + module Value = Schema.Node (XKey) (XKey) + + module Indexable = struct + module Inter = + Irmin_pack.Inode.Make_internal (Config) (H) (XKey) (Value) + + module CA = Pack.Make (Inter.Raw) + include Irmin_pack.Inode.Make (H) (XKey) (Value) (Inter) (CA) + + let v = CA.v + end + + include + Irmin.Node.Generic_key.Store (Contents) (Indexable) (H) + (Indexable.Val) + (M) + (P) + end + + module Node_portable = Node.Indexable.Val.Portable + + module Commit = struct + module Value = struct + include Schema.Commit (Node.Key) (XKey) + module Info = Schema.Info + + type hash = Hash.t [@@deriving irmin] + end + + module Pack_value = Irmin_pack.Pack_value.Of_commit (H) (XKey) (Value) + module Indexable = Indexable_mem (H) (Pack_value) + + include + Irmin.Commit.Generic_key.Store (Info) (Node) (Indexable) (H) (Value) + end + + module Commit_portable = Irmin.Commit.Portable.Of_commit (Commit.Value) + + module Branch = struct + module Key = B + + module Val = struct + include H + include Commit.Key + end + + module AW = Atomic_write (Key) (Val) + include Irmin_pack.Atomic_write.Closeable (AW) + + let v () = AW.v () >|= make_closeable + end + + module Slice = Irmin.Backend.Slice.Make (Contents) (Node) (Commit) + module Remote = Irmin.Backend.Remote.None (H) (B) + + module Repo = struct + type t = { + config : Irmin.Backend.Conf.t; + contents : read Contents.Indexable.t; + node : read Node.Indexable.t; + commit : read Commit.Indexable.t; + branch : Branch.t; + } + + let contents_t t : 'a Contents.t = t.contents + let node_t t : 'a Node.t = (contents_t t, t.node) + let commit_t t : 'a Commit.t = (node_t t, t.commit) + let branch_t t = t.branch + let config t = t.config + + let batch t f = + Commit.Indexable.batch t.commit (fun commit -> + Node.Indexable.batch t.node (fun node -> + Contents.Indexable.batch t.contents (fun contents -> + let contents : 'a Contents.t = contents in + let node : 'a Node.t = (contents, node) in + let commit : 'a Commit.t = (node, commit) in + f contents node commit))) + + let v config = + let root = Irmin_pack.Conf.root config in + let* contents = Contents.Indexable.v root in + let* node = Node.Indexable.v root in + let* commit = Commit.Indexable.v root in + let+ branch = Branch.v () in + { contents; node; commit; branch; config } + + let close t = + Contents.Indexable.close (contents_t t) >>= fun () -> + Node.Indexable.close (snd (node_t t)) >>= fun () -> + Commit.Indexable.close (snd (commit_t t)) >>= fun () -> + Branch.close t.branch + + (* An in-memory store is always in reload. *) + let reload _ = () + let flush _ = () + + let start_gc ?unlink ~throttle _ _ = + ignore unlink; + ignore throttle; + Lwt.return false + + let finalise_gc ?wait _ = + ignore wait; + Lwt.return false + end + end + + include Irmin.Of_backend (X) + + module Snapshot = struct + include X.Node.Indexable.Inter.Snapshot + + type t = Inode of inode | Blob of Backend.Contents.Val.t + [@@deriving irmin] + + let export ?on_disk:_ _ _ ~root_key:_ = Fmt.failwith "not implemented" + + module Import = struct + type process = unit + + let v ?on_disk:_ _ = Fmt.failwith "not implemented" + let save_elt _ _ = Fmt.failwith "not implemented" + let close _ = Fmt.failwith "not implemented" + end + end + + let integrity_check_inodes ?heads:_ _ = + Lwt.return + (Error (`Msg "Not supported: integrity checking of in-memory inodes")) + + let reload = X.Repo.reload + let flush = X.Repo.flush + let start_gc = X.Repo.start_gc + let finalise_gc = X.Repo.finalise_gc + let integrity_check ?ppf:_ ~auto_repair:_ _t = Ok `No_error + let traverse_pack_file _ _ = () + let test_traverse_pack_file _ _ = () + let stats ~dump_blob_paths_to:_ ~commit:_ _ = Lwt.return_unit + end +end diff --git a/vendors/irmin/src/irmin-pack/mem/irmin_pack_mem.mli b/vendors/irmin/src/irmin-pack/mem/irmin_pack_mem.mli new file mode 100644 index 0000000000000000000000000000000000000000..a73beaab0b3d9da9807b4175b06741753b675618 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/mem/irmin_pack_mem.mli @@ -0,0 +1,25 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** A fully in-memory implementation of the [Irmin_pack] flavour of Irmin + backend, intended for users that must be interoperable with the + idiosyncrasies of the persistent implementation. *) + +module Maker (_ : Irmin_pack.Conf.S) : + Irmin_pack.Maker + with type ('h, _) contents_key = 'h + and type 'h node_key = 'h + and type 'h commit_key = 'h diff --git a/vendors/irmin/src/irmin-pack/pack_key.ml b/vendors/irmin/src/irmin-pack/pack_key.ml new file mode 100644 index 0000000000000000000000000000000000000000..81d902c90d9c077e849ee8c5e961d556a92e4e78 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/pack_key.ml @@ -0,0 +1,125 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Pack_key_intf + +type 'hash state = + | Direct of { hash : 'hash; offset : int63; length : int } + | Indexed of 'hash + +type 'hash t = { mutable state : 'hash state } + +let inspect t = t.state +let to_hash t = match t.state with Direct t -> t.hash | Indexed h -> h + +let promote_exn t ~offset ~length = + let () = + match t.state with + | Direct _ -> + Fmt.failwith "Attempted to promote a key that is already Direct" + | Indexed _ -> () + in + t.state <- Direct { hash = to_hash t; offset; length } + +let t : type h. h Irmin.Type.t -> h t Irmin.Type.t = + fun hash_t -> + let open Irmin.Type in + variant "t" (fun direct indexed t -> + match t.state with + | Direct { hash; offset; length } -> direct (hash, offset, length) + | Indexed x1 -> indexed x1) + |~ case1 "Direct" [%typ: hash * int63 * int] (fun (hash, offset, length) -> + { state = Direct { hash; offset; length } }) + |~ case1 "Indexed" [%typ: hash] (fun x1 -> { state = Indexed x1 }) + |> sealv + +let t (type hash) (hash_t : hash Irmin.Type.t) = + let module Hash = struct + type t = hash + [@@deriving irmin ~equal ~compare ~pre_hash ~encode_bin ~decode_bin] + + let unboxed_encode_bin = Irmin.Type.(unstage (Unboxed.encode_bin t)) + let unboxed_decode_bin = Irmin.Type.(unstage (Unboxed.decode_bin t)) + + let encoded_size = + match Irmin.Type.Size.of_value t with + | Static n -> n + | Dynamic _ | Unknown -> + Fmt.failwith "Hash must have a fixed-width binary encoding" + end in + (* Equality and ordering on keys respects {i structural} equality semantics, + meaning two objects (containing keys) are considered equal even if their + children are stored at different offsets (either as duplicates in the same + pack file, or inside different pack files), or with different lengths (in + the event that the encoding environments were different). *) + let equal a b = Hash.equal (to_hash a) (to_hash b) in + let compare a b = Hash.compare (to_hash a) (to_hash b) in + (* The pre-hash image of a key is just the hash of the corresponding value. + + NOTE: it's particularly important that we discard the file offset when + computing hashes of structured values (e.g. inodes), so that this hashing + process is reproducible in different stores (w/ different offsets for the + values). *) + let pre_hash t f = Hash.pre_hash (to_hash t) f in + let encode_bin t f = Hash.encode_bin (to_hash t) f in + let unboxed_encode_bin t f = Hash.unboxed_encode_bin (to_hash t) f in + let decode_bin buf pos_ref = + { state = Indexed (Hash.decode_bin buf pos_ref) } + in + let unboxed_decode_bin buf pos_ref = + { state = Indexed (Hash.unboxed_decode_bin buf pos_ref) } + in + let size_of = Irmin.Type.Size.custom_static Hash.encoded_size in + Irmin.Type.like (t hash_t) ~pre_hash ~equal ~compare + ~bin:(encode_bin, decode_bin, size_of) + ~unboxed_bin:(unboxed_encode_bin, unboxed_decode_bin, size_of) + +let v_direct ~hash ~offset ~length = { state = Direct { hash; offset; length } } +let v_indexed hash = { state = Indexed hash } + +module type S = sig + type hash + + include S with type t = hash t and type hash := hash +end + +module Make (Hash : Irmin.Hash.S) = struct + type nonrec t = Hash.t t [@@deriving irmin] + type hash = Hash.t [@@deriving irmin ~of_bin_string] + + let to_hash = to_hash + let null_offset = Int63.minus_one + let null_length = -1 + + let null = + let buf = String.make Hash.hash_size '\000' in + let hash = + match hash_of_bin_string buf with Ok x -> x | Error _ -> assert false + in + v_direct ~hash ~offset:null_offset ~length:null_length + + let unfindable_of_hash hash = + v_direct ~hash ~offset:null_offset ~length:null_length +end + +module type Store_spec = sig + type ('h, _) contents_key = 'h t + type 'h node_key = 'h t + type 'h commit_key = 'h t +end + +module rec Store_spec : Store_spec = Store_spec diff --git a/vendors/irmin/src/irmin-pack/pack_key.mli b/vendors/irmin/src/irmin-pack/pack_key.mli new file mode 100644 index 0000000000000000000000000000000000000000..e7b62520a31880c81238356b7b4a77058c8ae514 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/pack_key.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Pack_key_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/pack_key_intf.ml b/vendors/irmin/src/irmin-pack/pack_key_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..c144bba7fe6b4c1815e5c920bd7332cb73af2916 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/pack_key_intf.ml @@ -0,0 +1,105 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + include Irmin.Key.S + + val null : t + + val unfindable_of_hash : hash -> t + (** [unfindable_of_hash h] is a key [k] such that [to_hash k = h], with an + unspecified internal representation. This function enables an efficient + implmentation of "portable" inodes, but is otherwise unused. Attempting to + dereference a key constructed in this way results in undefined behaviour. *) +end + +module type Sigs = sig + type 'hash t + (** The type of {i keys} referencing values stored in the [irmin-pack] + backend. *) + + (** The internal state of a key (read with {!inspect}). + + Invariant: keys of the form {!Indexed} always reference values that have + entries in the index (as otherwise these keys could not be dereferenced). *) + type 'hash state = private + | Direct of { hash : 'hash; offset : int63; length : int } + (** A "direct" pointer to a value stored at [offset] in the pack-file + (with hash [hash] and length [length]). Such keys can be + dereferenced from the store with a single IO read, without needing + to consult the index. + + They are built in-memory (e.g. after adding a fresh value to the + pack file), but have no corresponding encoding format, as the pack + format keeps length information with the values themselves. + + When decoding a inode, which references its children as single + offsets, we fetch the length information of the child at the same + time as fetching its hash (which we must do anyway in order to do an + integrity check), creating keys of this form. *) + | Indexed of 'hash + (** A pointer to an object in the pack file that is indexed. Reading the + object necessitates consulting the index, after which the key can be + promoted to {!Direct}. + + Such keys result from decoding pointers to other store objects + (nodes or commits) from commits or from the branch store. *) + + (** {2 Undereferencable keys} + + A key [k] is "undereferencable" with respect to some store handle [t] if + [find t k <> Some _]. Such keys should not arise during regular operation + of a single Irmin repository, but are still technically constructible in + the following ways: + + - {b storage corruption}. When decoding a key from disk, we may not + immediately check that it is dereferenceable for performance reasons. In + this case, any corruption to the key (or the referenced section of the + store) will be discovered on attempted [find] (or [mem]). + + - {b passing keys between store handles}. Read-only handles on a pack + store must explicitly {i reload} to observe recent writes to the store. + This means that any keys built by a read-write instance and passed to a + read-only instance will be undereferencable until that reader has + reloaded. + + - {b passing keys between repositories}. Keys created for one Irmin + repository may not be dereferenced with respect to another by design. *) + + val inspect : 'hash t -> 'hash state + val v_direct : hash:'h -> offset:int63 -> length:int -> 'h t + val v_indexed : 'h -> 'h t + val promote_exn : 'h t -> offset:int63 -> length:int -> unit + + module type S = sig + type hash + + (** @inline *) + include S with type t = hash t and type hash := hash + end + + module Make (Hash : Irmin.Hash.S) : S with type hash = Hash.t + + module type Store_spec = sig + type ('h, _) contents_key = 'h t + type 'h node_key = 'h t + type 'h commit_key = 'h t + end + + module Store_spec : Store_spec +end diff --git a/vendors/irmin/src/irmin-pack/pack_value.ml b/vendors/irmin/src/irmin-pack/pack_value.ml new file mode 100644 index 0000000000000000000000000000000000000000..3f6d35314499fbb71300dbb896b60bcd212a457b --- /dev/null +++ b/vendors/irmin/src/irmin-pack/pack_value.ml @@ -0,0 +1,228 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Pack_value_intf + +module Kind = struct + type t = + | Commit_v1 + | Commit_v2 + | Contents + | Inode_v1_unstable + | Inode_v1_stable + | Inode_v2_root + | Inode_v2_nonroot + | Dangling_parent_commit + + let to_magic = function + | Commit_v1 -> 'C' + | Commit_v2 -> 'D' + | Contents -> 'B' + | Inode_v1_unstable -> 'I' + | Inode_v1_stable -> 'N' + | Inode_v2_root -> 'R' + | Inode_v2_nonroot -> 'O' + | Dangling_parent_commit -> 'P' + + let of_magic_exn = function + | 'C' -> Commit_v1 + | 'D' -> Commit_v2 + | 'B' -> Contents + | 'I' -> Inode_v1_unstable + | 'N' -> Inode_v1_stable + | 'R' -> Inode_v2_root + | 'O' -> Inode_v2_nonroot + | 'P' -> Dangling_parent_commit + | c -> Fmt.failwith "Kind.of_magic: unexpected magic char %C" c + + let all = + [ + Commit_v1; + Commit_v2; + Contents; + Inode_v1_unstable; + Inode_v1_stable; + Inode_v2_root; + Inode_v2_nonroot; + Dangling_parent_commit; + ] + + let to_enum = function + | Commit_v1 -> 0 + | Commit_v2 -> 1 + | Contents -> 2 + | Inode_v1_unstable -> 3 + | Inode_v1_stable -> 4 + | Inode_v2_root -> 5 + | Inode_v2_nonroot -> 6 + | Dangling_parent_commit -> 7 + + let pp = + Fmt.of_to_string (function + | Commit_v1 -> "Commit_v1" + | Commit_v2 -> "Commit_v2" + | Contents -> "Contents" + | Inode_v1_unstable -> "Inode_v1_unstable" + | Inode_v1_stable -> "Inode_v1_stable" + | Inode_v2_root -> "Inode_v2_root" + | Inode_v2_nonroot -> "Inode_v2_nonroot" + | Dangling_parent_commit -> "Dangling_parent_commit") + + let length_header_exn : t -> length_header = + let some_varint = Some `Varint in + function + | Commit_v1 | Inode_v1_unstable | Inode_v1_stable -> None + | Commit_v2 | Inode_v2_root | Inode_v2_nonroot | Dangling_parent_commit -> + some_varint + | Contents -> + Fmt.failwith + "Can't determine length header for user-defined codec Contents" + + let t = Irmin.Type.map ~pp Irmin.Type.char of_magic_exn to_magic +end + +type ('h, 'a) value = { hash : 'h; kind : Kind.t; v : 'a } [@@deriving irmin] + +module type S = S with type kind := Kind.t +module type Persistent = Persistent with type kind := Kind.t + +let get_dynamic_sizer_exn : type a. a Irmin.Type.t -> string -> int -> int = + fun typ -> + match Irmin.Type.(Size.of_encoding typ) with + | Unknown -> + Fmt.failwith "Type must have a recoverable encoded length: %a" + Irmin.Type.pp_ty typ + | Static n -> fun _ _ -> n + | Dynamic f -> f + +module Of_contents + (Conf : Config) + (Hash : Irmin.Hash.S) + (Key : T) + (Data : Irmin.Type.S) = +struct + module Hash = Irmin.Hash.Typed (Hash) (Data) + + type t = Data.t [@@deriving irmin] + type key = Key.t + type hash = Hash.t + + let hash = Hash.hash + let kind = Kind.Contents + let length_header = Fun.const Conf.contents_length_header + let value = [%typ: (Hash.t, Data.t) value] + let encode_value = Irmin.Type.(unstage (encode_bin value)) + let decode_value = Irmin.Type.(unstage (decode_bin value)) + + let encode_bin ~dict:_ ~offset_of_key:_ hash v f = + encode_value { kind; hash; v } f + + let decode_bin ~dict:_ ~key_of_offset:_ ~key_of_hash:_ s off = + let t = decode_value s off in + t.v + + let decode_bin_length = get_dynamic_sizer_exn value + let kind _ = kind +end + +module Of_commit + (Hash : Irmin.Hash.S) + (Key : Irmin.Key.S with type hash = Hash.t) + (Commit : Irmin.Commit.Generic_key.S + with type node_key = Key.t + and type commit_key = Key.t) = +struct + module Hash = Irmin.Hash.Typed (Hash) (Commit) + + type t = Commit.t [@@deriving irmin] + type key = Key.t + type hash = Hash.t [@@deriving irmin ~encode_bin ~decode_bin] + + let hash = Hash.hash + let kind _ = Kind.Commit_v2 + + (* A commit implementation that uses integer offsets for addresses where possible. *) + module Commit_direct = struct + type address = Offset of int63 | Hash of Hash.t [@@deriving irmin] + + type t = { + node_offset : address; + parent_offsets : address list; + info : Commit.Info.t; + } + [@@deriving irmin ~encode_bin ~to_bin_string ~decode_bin] + + let size_of = + match Irmin.Type.Size.of_value t with + | Dynamic f -> f + | Static _ | Unknown -> assert false + end + + module Entry = struct + module V0 = struct + type t = (hash, Commit.t) value [@@deriving irmin ~decode_bin] + end + + module V1 = struct + type data = { length : int; v : Commit_direct.t } [@@deriving irmin] + type t = (hash, data) value [@@deriving irmin ~encode_bin ~decode_bin] + end + end + + let length_header = function + | Kind.Contents -> assert false + | x -> Kind.length_header_exn x + + let encode_bin ~dict:_ ~offset_of_key hash v f = + let address_of_key k : Commit_direct.address = + match offset_of_key k with + | None -> Hash (Key.to_hash k) + | Some k -> Offset k + in + let v = + let info = Commit.info v in + let node_offset = address_of_key (Commit.node v) in + let parent_offsets = List.map address_of_key (Commit.parents v) in + { Commit_direct.node_offset; parent_offsets; info } + in + let length = Commit_direct.size_of v in + Entry.V1.encode_bin { hash; kind = Commit_v2; v = { length; v } } f + + let decode_bin ~dict:_ ~key_of_offset ~key_of_hash s off = + let key_of_address : Commit_direct.address -> Key.t = function + | Offset x -> key_of_offset x + | Hash x -> key_of_hash x + in + match Kind.of_magic_exn s.[!off + Hash.hash_size] with + | Commit_v1 -> (Entry.V0.decode_bin s off).v + | Commit_v2 -> + let { v = { Entry.V1.v = commit; _ }; _ } = Entry.V1.decode_bin s off in + let info = commit.info in + let node = key_of_address commit.node_offset in + let parents = List.map key_of_address commit.parent_offsets in + Commit.v ~info ~node ~parents + | _ -> assert false + + let decode_bin_length = + let of_v0_entry = get_dynamic_sizer_exn Entry.V0.t + and of_v1_entry = get_dynamic_sizer_exn Entry.V1.t in + fun s off -> + match Kind.of_magic_exn s.[off + Hash.hash_size] with + | Commit_v1 -> of_v0_entry s off + | Commit_v2 -> of_v1_entry s off + | _ -> assert false +end diff --git a/vendors/irmin/src/irmin-pack/pack_value.mli b/vendors/irmin/src/irmin-pack/pack_value.mli new file mode 100644 index 0000000000000000000000000000000000000000..cb8363e34be4fda3f6b48a33d893dc88b5642095 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/pack_value.mli @@ -0,0 +1,46 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** This module defines abstractions over entries in the pack file, which are + encoded as follows: + + {v + ┌────────┬────────┬──────────────┬─────────┐ + │ Hash │ Kind │ Len(Value)? │ Value │ + └────────┴────────┴──────────────┴─────────┘ + ┆<┄ H ┄┄>┆<┄ K ┄┄>┆<┄┄┄┄ L? ┄┄┄┄>┆<┄┄ V ┄┄>┆ + ┆<┄┄┄┄┄┄┄┄┄┄┄ entry length, E ┄┄┄┄┄┄┄┄┄┄┄┄>┆ + v} + + The fields are as follows: + + - [Hash]: the (fixed-length) hash of the data stored in this entry; + + - [Kind]: the {i kind} of data being stored (contents, nodes, commits etc.), + encoded as a single "magic" character; + + - [Len(Value)]: an optional length header for the [Value] section of the + entry ({i not} including the length of the length header itself), encoded + using a variable-length encoding (LEB128). The presence of a length header + is determined by the [Kind] character. + + - [Value]: the data itself. + + The length of the overall pack {i entry}, as referenced in the {!Pack_index} + or in a direct {!Pack_key.t}, is equal to [E = H + K + L + V]. *) + +include Pack_value_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/pack_value_intf.ml b/vendors/irmin/src/irmin-pack/pack_value_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..ddc535ab03b4d7394dab84342a481ccaf7082bc9 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/pack_value_intf.ml @@ -0,0 +1,108 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +type length_header = [ `Varint ] option + +module type S = sig + include Irmin.Type.S + + type hash + type key + type kind + + val hash : t -> hash + val kind : t -> kind + + val length_header : kind -> length_header + (** Describes the length header formats for the {i data} sections of pack + entries. *) + + val encode_bin : + dict:(string -> int option) -> + offset_of_key:(key -> int63 option) -> + hash -> + t Irmin.Type.encode_bin + + val decode_bin : + dict:(int -> string option) -> + key_of_offset:(int63 -> key) -> + key_of_hash:(hash -> key) -> + t Irmin.Type.decode_bin + + val decode_bin_length : string -> int -> int +end + +module type Persistent = sig + type hash + + include S with type hash := hash and type key = hash Pack_key.t +end + +module type T = sig + type t +end + +(* A subset of [Irmin_pack.Conf.S] relevant to the format of pack entries, + copied here to avoid cyclic dependencies. *) +module type Config = sig + val contents_length_header : length_header +end + +module type Sigs = sig + module Kind : sig + type t = + | Commit_v1 + | Commit_v2 + | Contents + | Inode_v1_unstable + | Inode_v1_stable + | Inode_v2_root + | Inode_v2_nonroot + | Dangling_parent_commit + [@@deriving irmin] + + val all : t list + val to_enum : t -> int + val to_magic : t -> char + val of_magic_exn : char -> t + val pp : t Fmt.t + + val length_header_exn : t -> length_header + (** Raises an exception on [Contents], as the availability of a length + header is user defined. *) + end + + module type S = S with type kind := Kind.t + module type Persistent = Persistent with type kind := Kind.t + module type Config = Config + + module Of_contents + (_ : Config) + (Hash : Irmin.Hash.S) + (Key : T) + (Contents : Irmin.Contents.S) : + S with type t = Contents.t and type hash = Hash.t and type key = Key.t + + module Of_commit + (Hash : Irmin.Hash.S) + (Key : Irmin.Key.S with type hash = Hash.t) + (Commit : Irmin.Commit.Generic_key.S + with type node_key = Key.t + and type commit_key = Key.t) : + S with type t = Commit.t and type hash = Hash.t and type key = Key.t +end diff --git a/vendors/irmin/src/irmin-pack/s.ml b/vendors/irmin/src/irmin-pack/s.ml new file mode 100644 index 0000000000000000000000000000000000000000..8182f651c386f379a2437ff5ee3e5fd138e5f737 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/s.ml @@ -0,0 +1,222 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +exception RO_not_allowed + +module type Checkable = sig + type 'a t + type hash + + val integrity_check : + offset:int63 -> + length:int -> + hash -> + _ t -> + (unit, [ `Wrong_hash | `Absent_value ]) result +end + +(** [Irmin-pack]-specific extensions to the [Store] module type. *) +module type Specifics = sig + type repo + type commit_key + + val integrity_check : + ?ppf:Format.formatter -> + auto_repair:bool -> + repo -> + ( [> `Fixed of int | `No_error ], + [> `Cannot_fix of string | `Corrupted of int ] ) + result + (** Checks the integrity of the repository. if [auto_repair] is [true], will + also try to fix the issues. [ppf] is a formatter for progressive + reporting. [`Fixed] and [`Corrupted] report the number of fixed/corrupted + entries. *) + + val reload : repo -> unit + (** [reload t] reloads a readonly pack with the files on disk. Raises + [invalid_argument] if called by a read-write pack.*) + + val flush : repo -> unit + (** [flush t] flush read-write pack on disk. Raises [RO_Not_Allowed] if called + by a readonly instance.*) + + val start_gc : + ?unlink:bool -> + throttle:[ `Block | `Skip ] -> + repo -> + commit_key -> + bool Lwt.t + (** [start_gc] tries to start the gc process and returns true if the gc is + launched. + + If [unlink] is false then temporary files and files from the previous + generation will be kept on disk after the gc finished. This option is + useful for debugging. The default is true. + + If [throttle] is [Skip] and there is a concurrent gc, [start_gc] returns + false immediately without launching a second gc. If [throttle] is [Block] + and there is a concurrent gc, [start_gc] blocks waiting for the previous + gc to finish and only after launches a second gc. If the previous GC + failed, the function returns without launching a new GC. + + TODO: Detail exceptions raised. *) + + val finalise_gc : ?wait:bool -> repo -> bool Lwt.t + (** [finalise_gc ?wait repo] waits for the gc process to finish in order to + finalise it. It returns true if a GC was finalised. + + Finalising consists of mutating [repo] so that it points to the new file + and to flush the internal caches that could be referencing GCed objects. + + If [wait = true] (the default), the call blocks until the GC process + finishes. If [wait = false] it either returns [false], raises an exception + or finalises and returns [true]. + + If there are no running gcs, the call is a no-op and it returns false. + + TODO: Detail exceptions raised. *) +end + +module type S = sig + include Irmin.Generic_key.S + include Specifics with type repo := repo and type commit_key := commit_key + + val integrity_check_inodes : + ?heads:commit list -> + repo -> + ([> `Msg of string ], [> `Msg of string ]) result Lwt.t + + val traverse_pack_file : + [ `Reconstruct_index of [ `In_place | `Output of string ] + | `Check_index + | `Check_and_fix_index ] -> + Irmin.config -> + unit + + val test_traverse_pack_file : + [ `Reconstruct_index of [ `In_place | `Output of string ] + | `Check_index + | `Check_and_fix_index ] -> + Irmin.config -> + unit + + val stats : + dump_blob_paths_to:string option -> commit:commit -> repo -> unit Lwt.t + + module Snapshot : sig + type kinded_hash = Contents of hash * metadata | Node of hash + [@@deriving irmin] + + type entry = { step : string; hash : kinded_hash } [@@deriving irmin] + + type inode_tree = { + depth : int; + length : int; + pointers : (int * hash) list; + } + [@@deriving irmin] + + type v = Inode_tree of inode_tree | Inode_value of entry list + [@@deriving irmin] + + type inode = { v : v; root : bool } [@@deriving irmin] + + type t = Inode of inode | Blob of Backend.Contents.Val.t + [@@deriving irmin] + + val export : + ?on_disk:[ `Path of string ] -> + repo -> + (t -> unit Lwt.t) -> + root_key:Tree.kinded_key -> + int Lwt.t + (** [export ?on_disk repo f ~root_key] applies [f] to all inodes and + contents in a rooted tree, with root specified by [root_key]. + + The traversal requires an index to keep track of visited elements. + + - if [on_disk] is not specified, the index is in memory. + - if [on_disk] is [`Path path], a temporary index is created at path. + + The traversal order is stable. In [Inode_tree], it is lexicographic on + the [index] function (see {!Conf.inode_child_order}). In [Inode_value], + it is lexicographic on the steps. + + [f] is called in post-order, that is [f] is first called on the leaves, + and the last call to [f] is on the root designated by [root_key]. + + The traversal skips objects that are structurally equal to objects that + were already traversed. In other words, [export] internally uses a hash + set in order to guarantee that all the objects passed to [f] don't hash + the same way. + + Returns the total number of elements visited. *) + + module Import : sig + type process + + val v : ?on_disk:[ `Path of string | `Reuse ] -> repo -> process + (** [v ?on_disk repo] create a [snaphot] instance. The traversal requires + an index to keep track of visited elements. + + - if [on_disk] is not specified, the index is in memory. + - if [on_disk] is [`Path path], a temporary index is created at path. + - if [on_disk] is [`Reuse] the store's index is reused. *) + + val save_elt : process -> t -> node_key Lwt.t + (** [save_elt snapshot elt] saves [elt] to the store. *) + + val close : process -> repo -> unit + (** [close snapshot] close the [snaphot] instance.*) + end + end +end + +module S_is_a_store (X : S) : Irmin.Generic_key.S = X + +module type Maker = sig + type endpoint = unit + + include Irmin.Key.Store_spec.S + + module Make (Schema : Irmin.Schema.Extended) : + S + (* We can't have `with module Schema = Schema` here, since the Schema + on the RHS contains more information than the one on the LHS. We _want_ + to do something like `with module Schema = (Schema : Irmin.Schema.S)`, + but this isn't supported. + + TODO: extract these extensions as a separate functor argument instead. *) + with type Schema.Hash.t = Schema.Hash.t + and type Schema.Branch.t = Schema.Branch.t + and type Schema.Metadata.t = Schema.Metadata.t + and type Schema.Path.t = Schema.Path.t + and type Schema.Path.step = Schema.Path.step + and type Schema.Contents.t = Schema.Contents.t + and type Schema.Info.t = Schema.Info.t + and type contents_key = (Schema.Hash.t, Schema.Contents.t) contents_key + and type node_key = Schema.Hash.t node_key + and type commit_key = Schema.Hash.t commit_key + and type Backend.Remote.endpoint = endpoint +end + +module type Maker_persistent = + Maker + with type ('h, _) contents_key = 'h Pack_key.t + and type 'h node_key = 'h Pack_key.t + and type 'h commit_key = 'h Pack_key.t diff --git a/vendors/irmin/src/irmin-pack/stats.ml b/vendors/irmin/src/irmin-pack/stats.ml new file mode 100644 index 0000000000000000000000000000000000000000..6dc2aeda468983e25f095ae8e5599f675b67696c --- /dev/null +++ b/vendors/irmin/src/irmin-pack/stats.ml @@ -0,0 +1,116 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Metrics = Irmin.Metrics + +module Inode = struct + type Metrics.origin += Inode_stats + + type field = + | Inode_add + | Inode_remove + | Inode_of_seq + | Inode_of_raw + | Inode_rec_add + | Inode_rec_remove + | Inode_to_binv + | Inode_decode_bin + | Inode_encode_bin + + type t = { + mutable inode_add : int; + mutable inode_remove : int; + mutable inode_of_seq : int; + mutable inode_of_raw : int; + mutable inode_rec_add : int; + mutable inode_rec_remove : int; + mutable inode_to_binv : int; + mutable inode_decode_bin : int; + mutable inode_encode_bin : int; + } + [@@deriving irmin] + + type stat = t Metrics.t + + let create_inode () = + { + inode_add = 0; + inode_remove = 0; + inode_of_seq = 0; + inode_of_raw = 0; + inode_rec_add = 0; + inode_rec_remove = 0; + inode_to_binv = 0; + inode_decode_bin = 0; + inode_encode_bin = 0; + } + + let clear m = + let v = Metrics.state m in + v.inode_add <- 0; + v.inode_remove <- 0; + v.inode_of_seq <- 0; + v.inode_of_raw <- 0; + v.inode_rec_add <- 0; + v.inode_rec_remove <- 0; + v.inode_to_binv <- 0; + v.inode_decode_bin <- 0; + v.inode_encode_bin <- 0 + + let init () = + let initial_state = create_inode () in + Metrics.v ~origin:Inode_stats ~name:"inode_metric" ~initial_state t + + let export m = Metrics.state m + + let update ~field pack = + let f v = + match field with + | Inode_add -> v.inode_add <- succ v.inode_add + | Inode_remove -> v.inode_remove <- succ v.inode_remove + | Inode_of_seq -> v.inode_of_seq <- succ v.inode_of_seq + | Inode_of_raw -> v.inode_of_raw <- succ v.inode_of_raw + | Inode_rec_add -> v.inode_rec_add <- succ v.inode_rec_add + | Inode_rec_remove -> v.inode_rec_remove <- succ v.inode_rec_remove + | Inode_to_binv -> v.inode_to_binv <- succ v.inode_to_binv + | Inode_decode_bin -> v.inode_decode_bin <- succ v.inode_decode_bin + | Inode_encode_bin -> v.inode_encode_bin <- succ v.inode_encode_bin + in + let mut = Metrics.Mutate f in + Metrics.update pack mut +end + +type t = { inode : Inode.stat } + +let s = { inode = Inode.init () } +let get () = s +let reset_stats () = Inode.clear s.inode +let incr_inode_add () = Inode.update ~field:Inode.Inode_add s.inode +let incr_inode_remove () = Inode.update ~field:Inode.Inode_remove s.inode +let incr_inode_of_seq () = Inode.update ~field:Inode.Inode_of_seq s.inode +let incr_inode_of_raw () = Inode.update ~field:Inode.Inode_of_raw s.inode +let incr_inode_rec_add () = Inode.update ~field:Inode.Inode_rec_add s.inode + +let incr_inode_rec_remove () = + Inode.update ~field:Inode.Inode_rec_remove s.inode + +let incr_inode_to_binv () = Inode.update ~field:Inode.Inode_to_binv s.inode + +let incr_inode_decode_bin () = + Inode.update ~field:Inode.Inode_decode_bin s.inode + +let incr_inode_encode_bin () = + Inode.update ~field:Inode.Inode_encode_bin s.inode diff --git a/vendors/irmin/src/irmin-pack/stats.mli b/vendors/irmin/src/irmin-pack/stats.mli new file mode 100644 index 0000000000000000000000000000000000000000..180c2227878adf547306540976abcd72b81d61d7 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/stats.mli @@ -0,0 +1,68 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Inode : sig + type field = + | Inode_add + | Inode_remove + | Inode_of_seq + | Inode_of_raw + | Inode_rec_add + | Inode_rec_remove + | Inode_to_binv + | Inode_decode_bin + | Inode_encode_bin + + type t = private { + mutable inode_add : int; + mutable inode_remove : int; + mutable inode_of_seq : int; + mutable inode_of_raw : int; + mutable inode_rec_add : int; + mutable inode_rec_remove : int; + mutable inode_to_binv : int; + mutable inode_decode_bin : int; + mutable inode_encode_bin : int; + } + [@@deriving irmin] + (** The type for stats for a store S. + + - [inode_add + inode_remove + inode_of_seq + inode_of_raw] is the total + number of [Inode.Val.t] built; + - [inode_rec_add + inode_rec_remove] are witnesses of the quantity of work + that is done modifying inodes; + - [inode_to_binv] is the number of [Inode.Bin.v] built; + - [inode_encode_bin] is the number of [Bin] to [Compress] conversions; + - [inode_decode_bin] is the number of [Compress] to [Bin] conversions; *) + + type stat + + val export : stat -> t +end + +type t = { inode : Inode.stat } + +val reset_stats : unit -> unit +val get : unit -> t +val incr_inode_add : unit -> unit +val incr_inode_remove : unit -> unit +val incr_inode_of_seq : unit -> unit +val incr_inode_of_raw : unit -> unit +val incr_inode_rec_add : unit -> unit +val incr_inode_rec_remove : unit -> unit +val incr_inode_to_binv : unit -> unit +val incr_inode_decode_bin : unit -> unit +val incr_inode_encode_bin : unit -> unit diff --git a/vendors/irmin/src/irmin-pack/unix/append_only_file.ml b/vendors/irmin/src/irmin-pack/unix/append_only_file.ml new file mode 100644 index 0000000000000000000000000000000000000000..206210a6f79bcdf985ba3bd5b3aab2f082bbb4e2 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/append_only_file.ml @@ -0,0 +1,141 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +include Append_only_file_intf + +module Make (Io : Io.S) = struct + module Io = Io + + type rw_perm = { + buf : Buffer.t; + auto_flush_threshold : int; + auto_flush_callback : unit -> unit; + } + (** [rw_perm] contains the data necessary to operate in readwrite mode. *) + + type t = { + io : Io.t; + mutable persisted_end_offset : int63; + dead_header_size : int63; + rw_perm : rw_perm option; + } + + let create_rw ~path ~overwrite ~auto_flush_threshold ~auto_flush_callback = + let open Result_syntax in + let+ io = Io.create ~path ~overwrite in + let persisted_end_offset = Int63.zero in + let buf = Buffer.create 0 in + { + io; + persisted_end_offset; + dead_header_size = Int63.zero; + rw_perm = Some { buf; auto_flush_threshold; auto_flush_callback }; + } + + let open_rw ~path ~end_offset ~dead_header_size ~auto_flush_threshold + ~auto_flush_callback = + let open Result_syntax in + let+ io = Io.open_ ~path ~readonly:false in + let persisted_end_offset = end_offset in + let dead_header_size = Int63.of_int dead_header_size in + let buf = Buffer.create 0 in + { + io; + persisted_end_offset; + dead_header_size; + rw_perm = Some { buf; auto_flush_threshold; auto_flush_callback }; + } + + let open_ro ~path ~end_offset ~dead_header_size = + let open Result_syntax in + let+ io = Io.open_ ~path ~readonly:true in + let persisted_end_offset = end_offset in + let dead_header_size = Int63.of_int dead_header_size in + { io; persisted_end_offset; dead_header_size; rw_perm = None } + + let empty_buffer = function + | { rw_perm = Some { buf; _ }; _ } when Buffer.length buf > 0 -> false + | _ -> true + + let close t = + if not @@ empty_buffer t then Error `Pending_flush else Io.close t.io + + let readonly t = Io.readonly t.io + let path t = Io.path t.io + + let auto_flush_threshold = function + | { rw_perm = None; _ } -> None + | { rw_perm = Some rw_perm; _ } -> Some rw_perm.auto_flush_threshold + + let end_offset t = + match t.rw_perm with + | None -> t.persisted_end_offset + | Some rw_perm -> + let open Int63.Syntax in + t.persisted_end_offset + (Buffer.length rw_perm.buf |> Int63.of_int) + + let refresh_end_offset t new_end_offset = + match t.rw_perm with + | Some _ -> Error `Rw_not_allowed + | None -> + t.persisted_end_offset <- new_end_offset; + Ok () + + let flush t = + match t.rw_perm with + | None -> Error `Ro_not_allowed + | Some rw_perm -> + let open Result_syntax in + let open Int63.Syntax in + let s = Buffer.contents rw_perm.buf in + let off = t.persisted_end_offset + t.dead_header_size in + let+ () = Io.write_string t.io ~off s in + t.persisted_end_offset <- + t.persisted_end_offset + (String.length s |> Int63.of_int); + (* [truncate] is semantically identical to [clear], except that + [truncate] doesn't deallocate the internal buffer. We use + [clear] in legacy_io. *) + Buffer.truncate rw_perm.buf 0 + + let fsync t = Io.fsync t.io + + let read_exn t ~off ~len b = + let open Int63.Syntax in + let off' = off + Int63.of_int len in + if off' > t.persisted_end_offset then + raise (Errors.Pack_error `Read_out_of_bounds); + let off = off + t.dead_header_size in + Io.read_exn t.io ~off ~len b + + let read_to_string t ~off ~len = + let open Int63.Syntax in + let off' = off + Int63.of_int len in + if off' > t.persisted_end_offset then Error `Read_out_of_bounds + else + let off = off + t.dead_header_size in + Io.read_to_string t.io ~off ~len + + let append_exn t s = + match t.rw_perm with + | None -> raise Errors.RO_not_allowed + | Some rw_perm -> + assert (Buffer.length rw_perm.buf < rw_perm.auto_flush_threshold); + Buffer.add_string rw_perm.buf s; + if Buffer.length rw_perm.buf >= rw_perm.auto_flush_threshold then ( + rw_perm.auto_flush_callback (); + assert (empty_buffer t)) +end diff --git a/vendors/irmin/src/irmin-pack/unix/append_only_file.mli b/vendors/irmin/src/irmin-pack/unix/append_only_file.mli new file mode 100644 index 0000000000000000000000000000000000000000..47ec6aea4031694819a40da10a8a374a24d8d66b --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/append_only_file.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Append_only_file_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/unix/append_only_file_intf.ml b/vendors/irmin/src/irmin-pack/unix/append_only_file_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..ec3cb4d37be2d82ae218b75595bc8db838960e6b --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/append_only_file_intf.ml @@ -0,0 +1,163 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +module type S = sig + (** Abstraction for irmin-pack's append only files (i.e. suffix and dict). + + It is parameterized with [Io], a file system abstraction (e.g. unix, + mirage, eio_linux). + + It comprises a persistent file, an append buffer and take care of + automatically shifting offsets to deal with legacy headers. *) + + module Io : Io.S + + type t + + val create_rw : + path:string -> + overwrite:bool -> + auto_flush_threshold:int -> + auto_flush_callback:(unit -> unit) -> + (t, [> Io.create_error ]) result + (** Create a rw instance of [t] by creating the file. *) + + val open_rw : + path:string -> + end_offset:int63 -> + dead_header_size:int -> + auto_flush_threshold:int -> + auto_flush_callback:(unit -> unit) -> + (t, [> Io.open_error ]) result + (** Create a rw instance of [t] by opening an existing file at [path]. + + {3 End Offset} + + The file has an end offset at which new data will be saved. While this + information could be computed by looking at the size of the file, we + prefer storing that information elsewhere (i.e. in the control file). This + is why [open_rw] and [open_ro] take an [end_offset] parameter, and also + why [refresh_end_offset] exists. The abstractions above [Append_only_file] + are responsible for reading/writing the offsets from/to the control file. + + {3 [dead_header_size]} + + Designates a small area at the beginning of the file that should be + ignored. The offsets start after that area. + + The actual persisted size of a file is [end_offset + dead_header_size]. + + This concept exists in order to keep supporting [`V1] and [`V2] pack + stores with [`V3]. + + {3 Auto Flushes} + + One of the goal of the [Append_only_file] abstraction is to provide + buffered appends. [auto_flush_threshold] is the soft cap after which the + buffer should be flushed. If a call to [append_exn] fills the buffer, + [auto_flush_callback] will be called so that the parent abstraction takes + care of the flush procedure. *) + + val open_ro : + path:string -> + end_offset:int63 -> + dead_header_size:int -> + (t, [> Io.open_error ]) result + (** Create a ro instance of [t] by opening an existing file at [path] *) + + val close : t -> (unit, [> Io.close_error | `Pending_flush ]) result + (** Close the underlying file. + + The internal buffer is expected to be in a flushed state when [close] is + called. Otherwise, an error is returned. *) + + val end_offset : t -> int63 + (** [end_offset t] is the number of bytes of the file. That function doesn't + perform IO. + + {3 RW mode} + + It also counts the bytes not flushed yet. + + {3 RO mode} + + This information originates from the latest reload of the control file. + Calling [refresh_end_offset t] updates [end_offset]. *) + + val read_to_string : + t -> off:int63 -> len:int -> (string, [> Io.read_error ]) result + + val read_exn : t -> off:int63 -> len:int -> bytes -> unit + (** [read_exn t ~off ~len b] puts the [len] bytes of [t] at [off] to [b]. + + Raises [Io.Read_error] + + {3 RW mode} + + Attempting to read from the append buffer results in an + [`Read_out_of_bounds] error. This feature could easily be implemented in + the future if ever needed. It was not needed with io_legacy. + + {3 RO mode} + + It is not possible to read from an offset further than [end_offset t]. *) + + val append_exn : t -> string -> unit + (** [append_exn t ~off b] writes [b] to the end of [t]. Might trigger an auto + flush. + + Post-condition: [end_offset t - end_offset (old t) = String.length b]. + + Raises [Io.Write_error] + + {3 RW mode} + + Always raises [Io.Write_error `Ro_not_allowed] *) + + val flush : t -> (unit, [> Io.write_error ]) result + (** Flush the append buffer. Does not call [fsync]. + + {3 RO mode} + + Always returns [Error `Ro_not_allowed]. *) + + val fsync : t -> (unit, [> Io.write_error ]) result + (** Tell the os to fush its internal buffers. Does not call [flush]. + + {3 RO mode} + + Always returns [Error `Ro_not_allowed]. *) + + val refresh_end_offset : t -> int63 -> (unit, [> `Rw_not_allowed ]) result + (** Ingest the new end offset of the file. + + {3 RW mode} + + Always returns [Error `Rw_not_allowed]. *) + + val readonly : t -> bool + val auto_flush_threshold : t -> int option + val empty_buffer : t -> bool + val path : t -> string +end + +module type Sigs = sig + module type S = S + + module Make (Io : Io.S) : S with module Io = Io +end diff --git a/vendors/irmin/src/irmin-pack/unix/atomic_write.ml b/vendors/irmin/src/irmin-pack/unix/atomic_write.ml new file mode 100644 index 0000000000000000000000000000000000000000..ec71b30822a30f4c6553be30f49c2cde5f3704c8 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/atomic_write.ml @@ -0,0 +1,195 @@ +open Import +include Irmin_pack.Atomic_write + +let current_version = `V1 + +module Table (K : Irmin.Type.S) = Hashtbl.Make (struct + type t = K.t [@@deriving irmin ~short_hash ~equal] + + let hash = short_hash ?seed:None +end) + +module Make_persistent (K : Irmin.Type.S) (V : Value.S) = struct + module Tbl = Table (K) + module W = Irmin.Backend.Watch.Make (K) (V) + module Io_legacy = Io_legacy.Unix + + type key = K.t [@@deriving irmin ~pp ~to_bin_string ~of_bin_string] + type value = V.t [@@deriving irmin ~equal ~decode_bin ~of_bin_string] + type watch = W.watch + + type t = { + index : int63 Tbl.t; + cache : V.t Tbl.t; + block : Io_legacy.t; + w : W.t; + } + + let decode_bin = Irmin.Type.(unstage (decode_bin int32)) + + let read_length32 ~file_pos block = + let buf = Bytes.create 4 in + let n = Io_legacy.read block ~off:!file_pos buf in + assert (n = 4); + (file_pos := Int63.Syntax.(!file_pos + Int63.of_int 4)); + let pos_ref = ref 0 in + (* Bytes.unsafe_to_string usage: We assume Io_legacy.read_block returns unique + ownership of buf back to this function (this assumption holds currently; subsequent + modifications of that code need to ensure this remains the case); then in call to + Bytes.unsafe_to_string we give up ownership of buf (we do not modify the buffer + afterwards) and get ownership of resulting string; so this use is safe. *) + let v = decode_bin (Bytes.unsafe_to_string buf) pos_ref in + assert (!pos_ref = 4); + Int32.to_int v + + let entry = Irmin.Type.(pair (string_of `Int32) V.t) + let entry_to_bin_string = Irmin.Type.(unstage (to_bin_string entry)) + + let set_entry t ?off k v = + let k = key_to_bin_string k in + let buf = entry_to_bin_string (k, v) in + let () = + match off with + | None -> Io_legacy.append t.block buf + | Some off -> Io_legacy.set t.block buf ~off + in + Io_legacy.flush t.block + + let value_encoded_size = + match Irmin.Type.Size.of_value V.t with + | Repr.Size.Static n -> n + | Dynamic _ | Unknown -> + failwith + "Irmin_pack.Atomic_write: supplied value type must have a \ + fixed-width binary encoding" + + let refill t ~to_ ~from = + let file_pos = ref from in + let rec aux () = + if !file_pos >= to_ then () + else + let start = !file_pos in + let key_encoded_size = read_length32 ~file_pos t.block in + let buf_size = key_encoded_size + value_encoded_size in + let buf = + let buf = Bytes.create buf_size in + let n = Io_legacy.read t.block ~off:!file_pos buf in + assert (n = buf_size); + let open Int63.Syntax in + file_pos := !file_pos + Int63.of_int buf_size; + Bytes.unsafe_to_string buf + in + let key = + match String.sub buf 0 key_encoded_size |> key_of_bin_string with + | Ok k -> k + | Error (`Msg e) -> failwith e + in + let value = + let pos_ref = ref key_encoded_size in + let v = decode_bin_value buf pos_ref in + assert (!pos_ref = buf_size); + v + in + if not (equal_value value V.null) then Tbl.add t.cache key value; + Tbl.add t.index key start; + (aux [@tailcall]) () + in + aux () + + let sync_offset t = + let former_offset = Io_legacy.offset t.block in + let offset = Io_legacy.force_offset t.block in + if offset > former_offset then refill t ~to_:offset ~from:former_offset + + let unsafe_find t k = + [%log.debug "[branches] find %a" pp_key k]; + if Io_legacy.readonly t.block then sync_offset t; + try Some (Tbl.find t.cache k) with Not_found -> None + + let find t k = Lwt.return (unsafe_find t k) + + let unsafe_mem t k = + [%log.debug "[branches] mem %a" pp_key k]; + try Tbl.mem t.cache k with Not_found -> false + + let mem t v = Lwt.return (unsafe_mem t v) + + let unsafe_remove t k = + Tbl.remove t.cache k; + try + let off = Tbl.find t.index k in + set_entry t ~off k V.null + with Not_found -> () + + let remove t k = + [%log.debug "[branches] remove %a" pp_key k]; + unsafe_remove t k; + W.notify t.w k None + + let watches = W.v () + + let v ?(fresh = false) ?(readonly = false) file = + let block = + Io_legacy.v ~fresh ~version:(Some current_version) ~readonly file + in + let cache = Tbl.create 997 in + let index = Tbl.create 997 in + let t = { cache; index; block; w = watches } in + let offset = Io_legacy.force_offset block in + refill t ~to_:offset ~from:Int63.zero; + Lwt.return t + + let clear _ = Fmt.failwith "Unsupported operation" + + let unsafe_set t k v = + try + let off = Tbl.find t.index k in + Tbl.replace t.cache k v; + set_entry t ~off k v + with Not_found -> + let offset = Io_legacy.offset t.block in + set_entry t k v; + Tbl.add t.cache k v; + Tbl.add t.index k offset + + let set t k v = + [%log.debug "[branches %s] set %a" (Io_legacy.name t.block) pp_key k]; + unsafe_set t k v; + W.notify t.w k (Some v) + + let equal_v_opt = Irmin.Type.(unstage (equal (option V.t))) + + let unsafe_test_and_set t k ~test ~set = + let v = try Some (Tbl.find t.cache k) with Not_found -> None in + if not (equal_v_opt v test) then Lwt.return_false + else + let return () = Lwt.return_true in + match set with + | None -> unsafe_remove t k |> return + | Some v -> unsafe_set t k v |> return + + let test_and_set t k ~test ~set = + [%log.debug "[branches] test-and-set %a" pp_key k]; + unsafe_test_and_set t k ~test ~set >>= function + | true -> W.notify t.w k set >|= fun () -> true + | false -> Lwt.return_false + + let list t = + [%log.debug "[branches] list"]; + let keys = Tbl.fold (fun k _ acc -> k :: acc) t.cache [] in + Lwt.return keys + + let watch_key t = W.watch_key t.w + let watch t = W.watch t.w + let unwatch t = W.unwatch t.w + + let unsafe_close t = + Tbl.reset t.index; + Tbl.reset t.cache; + if not (Io_legacy.readonly t.block) then Io_legacy.flush t.block; + Io_legacy.close t.block; + W.clear t.w + + let close t = unsafe_close t + let flush t = Io_legacy.flush t.block +end diff --git a/vendors/irmin/src/irmin-pack/unix/atomic_write.mli b/vendors/irmin/src/irmin-pack/unix/atomic_write.mli new file mode 100644 index 0000000000000000000000000000000000000000..ddb81eebbe8f9a277cff35d757ef052928b68bb1 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/atomic_write.mli @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include module type of Irmin_pack.Atomic_write + +module Make_persistent (K : Irmin.Type.S) (V : Value.S) : + Persistent with type key = K.t and type value = V.t diff --git a/vendors/irmin/src/irmin-pack/unix/checks.ml b/vendors/irmin/src/irmin-pack/unix/checks.ml new file mode 100644 index 0000000000000000000000000000000000000000..709a4075d739598970f00c92569a2f6f7084d25c --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/checks.ml @@ -0,0 +1,630 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Checks_intf + +let setup_log = + let init style_renderer level = + let format_reporter = + let report _src level ~over k msgf = + let k _ = + over (); + k () + in + msgf @@ fun ?header:_ ?tags:_ fmt -> + match level with + | Logs.App -> + Fmt.kpf k Fmt.stderr + ("@[%a" ^^ fmt ^^ "@]@.") + Fmt.(styled `Bold (styled (`Fg `Cyan) string)) + ">> " + | _ -> Fmt.kpf k Fmt.stdout ("@[" ^^ fmt ^^ "@]@.") + in + { Logs.report } + in + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter format_reporter + in + Cmdliner.Term.(const init $ Fmt_cli.style_renderer () $ Logs_cli.level ()) + +let path = + let open Cmdliner.Arg in + required + @@ pos 0 (some string) None + @@ info ~doc:"Path to the Irmin store on disk" ~docv:"PATH" [] + +let deprecated_info = (Cmdliner.Term.info [@alert "-deprecated"]) + +module Make (Store : Store) = struct + module Hash = Store.Hash + module Index = Pack_index.Make (Hash) + + (** Read basic metrics from an existing store. *) + module Stat = struct + type size = Bytes of int [@@deriving irmin] + + type io = { size : size; offset : int63; version : Version.t } + [@@deriving irmin] + + type objects = { nb_commits : int; nb_nodes : int; nb_contents : int } + [@@deriving irmin] + + type t = { hash_size : size; log_size : int; objects : objects } + [@@deriving irmin] + + let traverse_index ~root log_size = + let index = Index.v_exn ~readonly:true ~fresh:false ~log_size root in + let bar, (progress_contents, progress_nodes, progress_commits) = + Utils.Object_counter.start () + in + let f _ (_, _, (kind : Pack_value.Kind.t)) = + match kind with + | Contents -> progress_contents () + | Inode_v1_stable | Inode_v1_unstable | Inode_v2_root | Inode_v2_nonroot + -> + progress_nodes () + | Commit_v1 | Commit_v2 -> progress_commits () + | Dangling_parent_commit -> assert false + in + Index.iter f index; + let nb_contents, nb_nodes, nb_commits = + Utils.Object_counter.finalise_with_stats bar + in + { nb_contents; nb_nodes; nb_commits } + + let conf root = Conf.init ~readonly:true ~fresh:false ~no_migrate:true root + + let run ~root = + [%logs.app "Getting statistics for store: `%s'@," root]; + let log_size = conf root |> Conf.index_log_size in + let objects = traverse_index ~root log_size in + { hash_size = Bytes Hash.hash_size; log_size; objects } + |> Irmin.Type.pp_json ~minify:false t Fmt.stdout; + Lwt.return_unit + + let term_internal = + Cmdliner.Term.(const (fun root () -> Lwt_main.run (run ~root)) $ path) + + let term = + let doc = "Print high-level statistics about the store." in + Cmdliner.Term.(term_internal $ setup_log, deprecated_info ~doc "stat") + end + + module Reconstruct_index = struct + let conf ~index_log_size root = + Conf.init ~readonly:false ~fresh:false ?index_log_size ~no_migrate:true + root + + let dest = + let open Cmdliner.Arg in + value + & pos 1 (some string) None + @@ info ~doc:"Path to the new index file" ~docv:"DEST" [] + + let index_log_size = + let open Cmdliner.Arg in + value + & opt (some int) None + @@ info ~doc:"Size of the index log file" [ "index-log-size" ] + + let run ~root ~output ?index_log_size () = + let conf = conf ~index_log_size root in + match output with + | None -> Store.traverse_pack_file (`Reconstruct_index `In_place) conf + | Some p -> Store.traverse_pack_file (`Reconstruct_index (`Output p)) conf + + let term_internal = + Cmdliner.Term.( + const (fun root output index_log_size () -> + run ~root ~output ?index_log_size ()) + $ path + $ dest + $ index_log_size) + + let term = + let doc = "Reconstruct index from an existing pack file." in + Cmdliner.Term. + (term_internal $ setup_log, deprecated_info ~doc "reconstruct-index") + end + + module Integrity_check_index = struct + let conf root = Conf.init ~readonly:true ~fresh:false ~no_migrate:true root + + let run ~root ~auto_repair () = + let conf = conf root in + if auto_repair then Store.traverse_pack_file `Check_and_fix_index conf + else Store.traverse_pack_file `Check_index conf + + let auto_repair = + let open Cmdliner.Arg in + value + & (flag @@ info ~doc:"Add missing entries in index" [ "auto-repair" ]) + + let term_internal = + Cmdliner.Term.( + const (fun root auto_repair () -> run ~root ~auto_repair ()) + $ path + $ auto_repair) + + let term = + let doc = "Check index integrity." in + Cmdliner.Term. + (term_internal $ setup_log, deprecated_info ~doc "integrity-check-index") + end + + module Integrity_check = struct + let conf root = Conf.init ~readonly:false ~fresh:false ~no_migrate:true root + + let handle_result ?name res = + let name = match name with Some x -> x ^ ": " | None -> "" in + match res with + | Ok (`Fixed n) -> Printf.printf "%sOk -- fixed %d\n%!" name n + | Ok `No_error -> Printf.printf "%sOk\n%!" name + | Error (`Cannot_fix x) -> + Printf.eprintf "%sError -- cannot fix: %s\n%!" name x + | Error (`Corrupted x) -> + Printf.eprintf "%sError -- corrupted: %d\n%!" name x + + let run ~root ~auto_repair = + let conf = conf root in + let+ repo = Store.Repo.v conf in + Store.integrity_check ~ppf:Format.err_formatter ~auto_repair repo + |> handle_result ?name:None + + let term_internal = + let auto_repair = + let open Cmdliner.Arg in + value + & (flag @@ info ~doc:"Automatically repair issues" [ "auto-repair" ]) + in + Cmdliner.Term.( + const (fun root auto_repair () -> Lwt_main.run (run ~root ~auto_repair)) + $ path + $ auto_repair) + + let term = + let doc = "Check integrity of an existing store." in + Cmdliner.Term. + (term_internal $ setup_log, deprecated_info ~doc "integrity-check") + end + + module Integrity_check_inodes = struct + let conf root = Conf.init ~readonly:true ~fresh:false ~no_migrate:true root + + let heads = + let open Cmdliner.Arg in + value + & opt (some (list ~sep:',' string)) None + & info [ "heads" ] ~doc:"List of head commit hashes" ~docv:"HEADS" + + let run ~root ~heads = + let conf = conf root in + let* repo = Store.Repo.v conf in + let* heads = + match heads with + | None -> Store.Repo.heads repo + | Some heads -> + Lwt_list.filter_map_s + (fun x -> + match Repr.of_string Store.Hash.t x with + | Ok x -> Store.Commit.of_hash repo x + | Error (`Msg m) -> Fmt.kstr Lwt.fail_with "Invalid hash %S" m) + heads + in + let* () = + Store.integrity_check_inodes ~heads repo >|= function + | Ok (`Msg msg) -> [%logs.app "Ok: %s" msg] + | Error (`Msg msg) -> Fmt.failwith "Error: %s" msg + in + Store.Repo.close repo + + let term_internal = + Cmdliner.Term.( + const (fun root heads () -> Lwt_main.run (run ~root ~heads)) + $ path + $ heads) + + let term = + let doc = "Check integrity of inodes in an existing store." in + Cmdliner.Term. + ( term_internal $ setup_log, + deprecated_info ~doc "integrity-check-inodes" ) + end + + module Stats_commit = struct + let conf root = Conf.init ~readonly:true ~fresh:false ~no_migrate:true root + + let commit = + let open Cmdliner.Arg in + value + & opt (some string) None + & info [ "commit" ] ~doc:"The commit whose underlying tree is traversed." + ~docv:"COMMIT" + + let dump_blob_paths_to = + let open Cmdliner.Arg in + value + & opt (some string) None + & info [ "dump_blob_paths_to" ] + ~doc:"Print all paths to a blob in the tree in a file." + + let run ~root ~commit ~dump_blob_paths_to () = + let conf = conf root in + let* repo = Store.Repo.v conf in + let* commit = + match commit with + | None -> ( + let* heads = Store.Repo.heads repo in + match heads with + | [] -> Lwt.fail_with "No heads found" + | [ head ] -> Lwt.return head + | ls -> + Fmt.kstr Lwt.fail_with + "Several heads found, please specify one. Heads = %a" + Fmt.(list ~sep:comma Store.Commit.pp_hash) + ls) + | Some hash -> ( + match Repr.of_string Store.Hash.t hash with + | Ok x -> ( + Store.Commit.of_hash repo x >>= function + | None -> + Fmt.kstr Lwt.fail_with "Commit with hash %s not found" hash + | Some x -> Lwt.return x) + | Error (`Msg m) -> Fmt.kstr Lwt.fail_with "Invalid hash %S" m) + in + let* () = Store.stats ~dump_blob_paths_to ~commit repo in + Store.Repo.close repo + + let term_internal = + Cmdliner.Term.( + const (fun root commit dump_blob_paths_to () -> + Lwt_main.run (run ~root ~commit ~dump_blob_paths_to ())) + $ path + $ commit + $ dump_blob_paths_to) + + let term = + let doc = + "Traverse one commit, specified with the --commit argument, in the \ + store for stats. If no commit is specified the current head is used." + in + Cmdliner.Term. + (term_internal $ setup_log, deprecated_info ~doc "stat-store") + end + + module Cli = struct + open Cmdliner + + let main + ?(terms = + [ + Stat.term; + Reconstruct_index.term; + Integrity_check.term; + Integrity_check_inodes.term; + Integrity_check_index.term; + Stats_commit.term; + ]) () : empty = + let default = + let default_info = + let doc = "Check Irmin data-stores." in + deprecated_info ~doc "irmin-fsck" + in + Term.(ret (const (`Help (`Auto, None))), default_info) + in + let deprecated_eval_choice = (Term.eval_choice [@alert "-deprecated"]) in + let deprecated_exit = (Term.exit [@alert "-deprecated"]) in + deprecated_eval_choice default terms |> deprecated_exit; + assert false + end + + let cli = Cli.main +end + +module Index (Index : Pack_index.S) = struct + let null = + match Sys.os_type with + | "Unix" | "Cygwin" -> "/dev/null" + | "Win32" -> "NUL" + | _ -> invalid_arg "invalid os type" + + let integrity_check ?ppf ~auto_repair ~check index = + let ppf = + match ppf with + | Some p -> p + | None -> open_out null |> Format.formatter_of_out_channel + in + Fmt.pf ppf "Running the integrity_check.\n%!"; + let nb_absent = ref 0 in + let nb_corrupted = ref 0 in + let exception Cannot_fix in + let counter, (progress_contents, progress_nodes, progress_commits) = + Utils.Object_counter.start () + in + let f (k, (offset, length, (kind : Pack_value.Kind.t))) = + match kind with + | Contents -> + progress_contents (); + check ~kind:`Contents ~offset ~length k + | Inode_v1_stable | Inode_v1_unstable | Inode_v2_root | Inode_v2_nonroot + -> + progress_nodes (); + check ~kind:`Node ~offset ~length k + | Commit_v1 | Commit_v2 -> + progress_commits (); + check ~kind:`Commit ~offset ~length k + | Dangling_parent_commit -> assert false + in + let result = + if auto_repair then + try + Index.filter index (fun binding -> + match f binding with + | Ok () -> true + | Error `Wrong_hash -> raise Cannot_fix + | Error `Absent_value -> + incr nb_absent; + false); + if !nb_absent = 0 then Ok `No_error else Ok (`Fixed !nb_absent) + with Cannot_fix -> Error (`Cannot_fix "Not implemented") + else ( + Index.iter + (fun k v -> + match f (k, v) with + | Ok () -> () + | Error `Wrong_hash -> incr nb_corrupted + | Error `Absent_value -> incr nb_absent) + index; + if !nb_absent = 0 && !nb_corrupted = 0 then Ok `No_error + else Error (`Corrupted (!nb_corrupted + !nb_absent))) + in + Utils.Object_counter.finalise counter; + result +end + +module Stats (S : sig + type step + + val step_t : step Irmin.Type.t + + module Hash : Irmin.Hash.S +end) = +struct + type step = Node of S.step | Inode + type path = step list + + module Metrics : sig + type max + type node + + val max_length : node -> int + val all_paths : node -> path list + val mp : node -> max + val maximum : max -> int + val maximal_count : max -> int + val representative : max -> path + + val v : + ?maximal_count:int -> maximum:int -> representative:path -> unit -> max + + val empty_root_node : node + val empty_node : node + val empty_max : max + val update_node : node -> node -> step -> int -> node + val update_width : node -> int -> max -> max + val pp : max Fmt.t + val pp_all_paths : node Fmt.t + end = struct + type max = { maximum : int; maximal_count : int; representative : path } + + type node = { + all_paths : path list; + (* All paths to a node. *) + max_length : int; + (* The max length of a path to a node. *) + mp : max; + (* The maximum size of a membership proof: the number of siblings at + every level along the path. *) + } + + let max_length { max_length; _ } = max_length + let all_paths { all_paths; _ } = all_paths + let mp { mp; _ } = mp + let maximum { maximum; _ } = maximum + let representative { representative; _ } = representative + let maximal_count { maximal_count; _ } = maximal_count + + let v ?(maximal_count = 1) ~maximum ~representative () = + { maximum; maximal_count; representative } + + let empty_max = { maximum = 0; maximal_count = 0; representative = [] } + + let empty_root_node = + let mp = empty_max in + { all_paths = [ [] ]; max_length = 0; mp } + + let empty_node = + let mp = empty_max in + { all_paths = []; max_length = 0; mp } + + let incr ({ maximal_count; _ } as t) = + { t with maximal_count = maximal_count + 1 } + + let update_mp stat_k stat_pred step nb_siblings = + let mp = stat_k.maximum + nb_siblings in + if stat_pred.maximum > mp then stat_pred + else if stat_pred.maximum = mp && not (mp = 0) then incr stat_pred + else + let path_to_k = stat_k.representative in + let new_path_to_pred = step :: path_to_k in + v ~maximum:mp ~representative:new_path_to_pred () + + let update_width stat_k width_k max_width = + if max_width.maximum > width_k then max_width + else if max_width.maximum = width_k then incr max_width + else + let representative = List.hd stat_k.all_paths in + v ~maximum:width_k ~representative () + + let update_path paths_to_k step_k_to_n paths_to_n = + let new_paths_to_n = + List.rev_map (fun rev_path -> step_k_to_n :: rev_path) paths_to_k + in + List.rev_append new_paths_to_n paths_to_n + + let update_node stat_k stat_pred step_k_to_pred nb_siblings = + let all_paths, max_length = + match step_k_to_pred with + | Inode -> + (* Do not update if pred is an inode. *) + (stat_k.all_paths, stat_k.max_length) + | Node _ -> + let paths_to_pred = + update_path stat_k.all_paths step_k_to_pred stat_pred.all_paths + in + let length = + (* The new current length to pred. *) + let lk = stat_k.max_length + 1 in + (* The previous max length to pred. *) + let ln = stat_pred.max_length in + max lk ln + in + (paths_to_pred, length) + in + let mp = update_mp stat_k.mp stat_pred.mp step_k_to_pred nb_siblings in + let stat_pred' = { all_paths; max_length; mp } in + stat_pred' + + let pp_step ppf = function + | Inode -> Fmt.pf ppf "-" + | Node x -> Fmt.pf ppf "%a" (Irmin.Type.pp S.step_t) x + + let pp_path = Fmt.list ~sep:(Fmt.any "/") pp_step + + let pp_all_paths fmt stats = + List.iter + (fun l -> Fmt.pf fmt "%a\n" pp_path (List.rev l)) + stats.all_paths + + let pp = + let open Fmt.Dump in + record + [ + field "maximum" (fun t -> t.maximum) Fmt.int; + field "maximal_count" (fun t -> t.maximal_count) Fmt.int; + field "representative" (fun t -> List.rev t.representative) pp_path; + ] + end + + type t = { + visited : (S.Hash.t, Metrics.node) Hashtbl.t; + mutable max_width : Metrics.max; + mutable max_mp : int; + mutable max_length : int; + } + + let v () = + let visited = Hashtbl.create 100 in + let max_width = Metrics.empty_max in + { visited; max_width; max_length = 0; max_mp = 0 } + + let get t k = + try Hashtbl.find t.visited k with Not_found -> Metrics.empty_node + + let visit_node t k preds ~nb_children ~width = + let preds = + List.map + (function None, x -> (Inode, x) | Some s, x -> (Node s, x)) + preds + in + let stat_k = get t k in + let visit step pred = + let stat_pred = get t pred in + let nb_siblings = nb_children - 1 in + let stat_pred' = Metrics.update_node stat_k stat_pred step nb_siblings in + Hashtbl.replace t.visited pred stat_pred' + in + let () = + List.iter + (function + | Inode, `Inode x -> visit Inode x + | Node s, `Node x -> visit (Node s) x + | Node s, `Contents x -> visit (Node s) x + | _ -> assert false) + preds + in + (* Once we updated its preds we can remove the node from the + table. If its a max width, we update the max_width stats. *) + Hashtbl.remove t.visited k; + t.max_width <- Metrics.update_width stat_k width t.max_width + + let visit_commit t root_node = + let stat = Metrics.empty_root_node in + Hashtbl.replace t.visited root_node stat + + (* Update the max length and max_mp while traversing the contents. *) + let visit_contents t k = + let stat = get t k in + let max_length = Metrics.max_length stat in + if max_length > t.max_length then t.max_length <- max_length; + let maximum = Metrics.mp stat |> Metrics.maximum in + if maximum > t.max_mp then t.max_mp <- maximum + + let pp_results ~dump_blob_paths_to t = + [%log.app "Max width = %a" Metrics.pp t.max_width]; + let maximal_count, representative = + Hashtbl.fold + (fun _ (stat : Metrics.node) ((counter, _) as acc) -> + let maximum = Metrics.mp stat |> Metrics.maximum in + if maximum = t.max_mp then + let maximal_count = Metrics.mp stat |> Metrics.maximal_count in + let counter' = counter + maximal_count in + let repr = Metrics.mp stat |> Metrics.representative in + (counter', repr) + else acc) + t.visited (0, []) + in + let max_mp = + Metrics.v ~maximal_count ~representative ~maximum:t.max_mp () + in + [%log.app "Max number of path-adjacent nodes = %a" Metrics.pp max_mp]; + (* Count all paths that have max length. *) + let maximal_count, representative = + Hashtbl.fold + (fun _ (stat : Metrics.node) acc -> + if Metrics.max_length stat = t.max_length then + List.fold_left + (fun ((counter, _) as acc) l -> + if List.length l = t.max_length then (counter + 1, l) else acc) + acc (Metrics.all_paths stat) + else acc) + t.visited (0, []) + in + let max_length = + Metrics.v ~maximal_count ~representative ~maximum:t.max_length () + in + [%log.app "Max length = %a" Metrics.pp max_length]; + match dump_blob_paths_to with + | None -> () + | Some filename -> + let chan = open_out filename in + let fmt = Format.formatter_of_out_channel chan in + Hashtbl.iter (fun _ stats -> Metrics.pp_all_paths fmt stats) t.visited; + Fmt.flush fmt (); + close_out chan +end diff --git a/vendors/irmin/src/irmin-pack/unix/checks.mli b/vendors/irmin/src/irmin-pack/unix/checks.mli new file mode 100644 index 0000000000000000000000000000000000000000..e8b7970d40fd0ce56455c69b828efd1c68c9f7d9 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/checks.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Offline stats for Irmin stores. *) + +include Checks_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/unix/checks_intf.ml b/vendors/irmin/src/irmin-pack/unix/checks_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..d0b75e6e68483f1e0bc68e9b26a5783051dc1852 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/checks_intf.ml @@ -0,0 +1,167 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +type empty = | + +module type Subcommand = sig + type run + + val run : run + + val term_internal : (unit -> unit) Cmdliner.Term.t + (** A pre-packaged [Cmdliner] term for executing {!run}. *) + + val term : (unit Cmdliner.Term.t * Cmdliner.Term.info[@alert "-deprecated"]) + (** [term] is {!term_internal} plus documentation and logs initialisation *) +end + +module type S = sig + (** Reads basic metrics from an existing store and prints them to stdout. *) + module Stat : sig + include Subcommand with type run := root:string -> unit Lwt.t + + (** Internal implementation utilities exposed for use in other integrity + checks. *) + + type size = Bytes of int [@@deriving irmin] + + type objects = { nb_commits : int; nb_nodes : int; nb_contents : int } + [@@deriving irmin] + + val traverse_index : root:string -> int -> objects + end + + module Reconstruct_index : + Subcommand + with type run := + root:string -> + output:string option -> + ?index_log_size:int -> + unit -> + unit + (** Rebuilds an index for an existing pack file *) + + (** Checks the integrity of a store *) + module Integrity_check : sig + include + Subcommand with type run := root:string -> auto_repair:bool -> unit Lwt.t + + val handle_result : + ?name:string -> + ( [< `Fixed of int | `No_error ], + [< `Cannot_fix of string | `Corrupted of int ] ) + result -> + unit + end + + (** Checks the integrity of the index in a store *) + module Integrity_check_index : sig + include + Subcommand + with type run := root:string -> auto_repair:bool -> unit -> unit + end + + (** Checks the integrity of inodes in a store *) + module Integrity_check_inodes : sig + include + Subcommand + with type run := root:string -> heads:string list option -> unit Lwt.t + end + + (** Traverses a commit to get stats on its underlying tree. *) + module Stats_commit : sig + include + Subcommand + with type run := + root:string -> + commit:string option -> + dump_blob_paths_to:string option -> + unit -> + unit Lwt.t + end + + val cli : + ?terms: + ((unit Cmdliner.Term.t * Cmdliner.Term.info)[@alert "-deprecated"]) list -> + unit -> + empty + (** Run a [Cmdliner] binary containing tools for running offline checks. + [terms] defaults to the set of checks in this module. *) +end + +module type Store = sig + include Irmin.S + include Irmin_pack.S with type repo := repo and type commit := commit +end + +type integrity_error = [ `Wrong_hash | `Absent_value ] + +module type Sigs = sig + type integrity_error = [ `Wrong_hash | `Absent_value ] + type nonrec empty = empty + + val setup_log : unit Cmdliner.Term.t + val path : string Cmdliner.Term.t + + module type Subcommand = Subcommand + module type S = S + + module Make (_ : Store) : S + + module Index (Index : Pack_index.S) : sig + val integrity_check : + ?ppf:Format.formatter -> + auto_repair:bool -> + check: + (kind:[> `Commit | `Contents | `Node ] -> + offset:int63 -> + length:int -> + Index.key -> + (unit, [< `Absent_value | `Wrong_hash ]) result) -> + Index.t -> + ( [> `Fixed of int | `No_error ], + [> `Cannot_fix of string | `Corrupted of int ] ) + result + end + + module Stats (S : sig + type step + + val step_t : step Irmin.Type.t + + module Hash : Irmin.Hash.S + end) : sig + type t + + val v : unit -> t + val visit_commit : t -> S.Hash.t -> unit + val visit_contents : t -> S.Hash.t -> unit + + val visit_node : + t -> + S.Hash.t -> + (S.step option + * [ `Contents of S.Hash.t | `Inode of S.Hash.t | `Node of S.Hash.t ]) + list -> + nb_children:int -> + width:int -> + unit + + val pp_results : dump_blob_paths_to:string option -> t -> unit + end +end diff --git a/vendors/irmin/src/irmin-pack/unix/control_file.ml b/vendors/irmin/src/irmin-pack/unix/control_file.ml new file mode 100644 index 0000000000000000000000000000000000000000..cef79f885f6eb323884a856697cbe07f967d5a6e --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/control_file.ml @@ -0,0 +1,116 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +include Control_file_intf + +module Plv3 = struct + include Payload_v3 + + let of_bin_string = Irmin.Type.of_bin_string t |> Irmin.Type.unstage + let to_bin_string = Irmin.Type.to_bin_string t |> Irmin.Type.unstage +end + +module Version = Irmin_pack.Version + +module Data = struct + (** Type of what's encoded in the control file. The variant tag is encoded as + a [Version.t]. *) + type t = V3 of Plv3.t + + let to_bin_string = function + | V3 payload -> Version.to_bin `V3 ^ Plv3.to_bin_string payload + + let of_bin_string s = + let open Result_syntax in + let* left, right = + let len = String.length s in + try Ok (String.sub s 0 8, String.sub s 8 (len - 8)) + with Invalid_argument _ -> Error `Corrupted_control_file + in + let* version = + match Version.of_bin left with + | None -> Error (`Unknown_major_pack_version left) + | Some `V3 -> Ok `V3 + | Some (`V1 | `V2) -> assert false + in + match version with + | `V3 -> ( + match Plv3.of_bin_string right with + | Ok x -> Ok (V3 x) + | Error _ -> Error `Corrupted_control_file) +end + +module Make (Io : Io.S) = struct + module Io = Io + + type t = { io : Io.t; mutable payload : Latest_payload.t } + + let write io payload = + let s = Data.(to_bin_string (V3 payload)) in + + (* The data must fit inside a single page for atomic updates of the file *) + assert (String.length s <= Io.page_size); + + Io.write_string io ~off:Int63.zero s + + let read io = + let open Result_syntax in + let* len = Io.read_size io in + let len = Int63.to_int len in + let* string = Io.read_to_string io ~off:Int63.zero ~len in + Data.of_bin_string string + + let read io = + match read io with + | Ok x -> Ok x + | Error (`Read_out_of_bounds | `Corrupted_control_file) -> + Error `Corrupted_control_file + | Error `Invalid_argument -> assert false + | Error (`Io_misc _ | `Closed | `Unknown_major_pack_version _) as e -> e + + let create_rw ~path ~overwrite payload = + let open Result_syntax in + let* io = Io.create ~path ~overwrite in + let+ () = write io payload in + { io; payload } + + let open_ ~path ~readonly = + let open Result_syntax in + let* io = Io.open_ ~path ~readonly in + let+ data = read io in + let payload = match data with Data.V3 payload -> payload in + { io; payload } + + let close t = Io.close t.io + let readonly t = Io.readonly t.io + let payload t = t.payload + + let reload t = + let open Result_syntax in + if not @@ Io.readonly t.io then Error `Rw_not_allowed + else + let+ data = read t.io in + let payload = match data with Data.V3 payload -> payload in + t.payload <- payload + + let set_payload t payload = + let open Result_syntax in + let+ () = write t.io payload in + t.payload <- payload + + let fsync t = Io.fsync t.io +end diff --git a/vendors/irmin/src/irmin-pack/unix/control_file.mli b/vendors/irmin/src/irmin-pack/unix/control_file.mli new file mode 100644 index 0000000000000000000000000000000000000000..9301acc1034739ea9fe34dd98123b0148f6fe5f1 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/control_file.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Control_file_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/unix/control_file_intf.ml b/vendors/irmin/src/irmin-pack/unix/control_file_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..a1f88fb7845b6410e08159e02b91ec82d7b483c4 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/control_file_intf.ml @@ -0,0 +1,204 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) +open! Import + +module Payload_v3 = struct + type from_v1_v2_post_upgrade = { entry_offset_at_upgrade_to_v3 : int63 } + [@@deriving irmin] + (** [entry_offset_at_upgrade_to_v3] is the offset of the first entry that is + known to have been created using [irmin_pack_version = `V2] or more. The + entries before that point may be v1 entries. V1 entries need an entry in + index because it is the only place their lenght is stored. *) + + type from_v3_gced = { entry_offset_suffix_start : int63; generation : int } + [@@deriving irmin] + (** [entry_offset_suffix_start] is 0 if the suffix file was never garbage + collected. Otherwise it is the offset of the very first entry of the + suffix file. Note that offsets in the suffix file are virtual. The garbage + collections don't reset the offsets. + + [generation] is the number of past GCs. A suffix file, a prefix file and a + mapping containing that integer in their filename exist. *) + + (** [From_v1_v2_post_upgrade] corresponds to a pack store that was upgraded to + [`V3]. It contains infos related to backward compatibility. GCs are + forbidden on it. + + [From_v3] corresponds to a pack store that was created using [`V3] code. + It never underwent a GC. + + [From_v3_used_non_minimal_indexing_strategy] corresponds to a pack store + that was created using [`V3] code. It never underwent a GC and it will + never be possible to GC it because entries were pushed using a non-minimal + indexing strategy. + + The [T*] tags are provisional tags that the binary decoder is aware of and + that may in the future be used to add features to the [`V3] payload. *) + type status = + | From_v1_v2_post_upgrade of from_v1_v2_post_upgrade + | From_v3_no_gc_yet + | From_v3_used_non_minimal_indexing_strategy + | From_v3_gced of from_v3_gced + | T1 + | T2 + | T3 + | T4 + | T5 + | T6 + | T7 + | T8 + | T9 + | T10 + | T11 + | T12 + | T13 + | T14 + | T15 + [@@deriving irmin] + + type t = { + dict_offset_end : int63; + entry_offset_suffix_end : int63; + status : status; + } + [@@deriving irmin] + (** The [`V3] payload of the irmin-pack control file. [`V3] is a major + version. If [`V4] ever exists, it will have its own dedicated payload, but + the [`V3] definition will still have to stick in the codebase for backward + compatibilty of old irmin-pack directories. + + A store may only change its major version during an [open_rw] in + [File_manager]. Note that upgrading a major version is the only reason why + [open_rw] would modify files in an irmin-pack directory. + + For a given major version, the format of a payload may change, but only in + a backward compatible way. I.e., all versions of irmin-pack should forever + be able to decode a [`V3] control file, it allows for control file + corruption and out-of-date code to be distinguishable. + + It is legal for the payload decoder to not fully consume the input buffer. + Remaining bytes means that the definition of a payload was changed. + + {3 Fields} + + [dict_offset_end] is the offset in the dict file just after the last valid + dict bytes. The next data to be pushed to the dict will be pushed at this + offset. + + [entry_offset_suffix_end] is similar to [dict_offset_end] but for the + suffix file. + + [status] is a variant that encode the state of the irmin-pack directory. + This field MUST be the last field of the record, in order to allow + extensions *) +end + +module Latest_payload = Payload_v3 + +module type S = sig + (** Abstraction for irmin-pack's control file. + + It is parameterized with [Io], a file system abstraction (e.g. unix, + mirage, eio_linux). + + None of the functions raise exceptions. *) + + module Io : Io.S + + type t + + val create_rw : + path:string -> + overwrite:bool -> + Latest_payload.t -> + (t, [> Io.create_error | Io.write_error ]) result + (** Create a rw instance of [t] by creating a control file. *) + + type open_error := + [ `Corrupted_control_file + | `Io_misc of Io.misc_error + | `No_such_file_or_directory + | `Not_a_file + | `Closed + | `Unknown_major_pack_version of string ] + + val open_ : path:string -> readonly:bool -> (t, [> open_error ]) result + (** Create a rw instance of [t] by reading an existing file at [path]. *) + + val close : t -> (unit, [> Io.close_error ]) result + + val payload : t -> Latest_payload.t + (** [payload t] is the payload in [t]. + + That function doesn't perform IO. + + {3 RW mode} + + [payload t] is the payload, as it was written to the file system. + + {3 RO mode} + + [payload t] is the [payload], as it was seen during [open_] or during the + most recent [reload]. *) + + type reload_error := + [ `Corrupted_control_file + | `Io_misc of Io.misc_error + | `Closed + | `Rw_not_allowed + | `Unknown_major_pack_version of string ] + + val reload : t -> (unit, [> reload_error ]) result + (** {3 RW mode} + + Always returns an error. + + {3 RO mode} + + Reread the file on disk. + + If the file changed since the last read, the payload in [t] is updated to + match the content of the file. *) + + val set_payload : t -> Latest_payload.t -> (unit, [> Io.write_error ]) result + (** {3 RW mode} + + Write a new payload on disk. + + {3 RO mode} + + Always returns an error. *) + + val readonly : t -> bool + + val fsync : t -> (unit, [> Io.write_error ]) result + (** {3 RW mode} + + Tell the os to fush its internal buffers. + + {3 RO mode} + + Always returns [Error `Ro_not_allowed]. *) +end + +module type Sigs = sig + module Latest_payload = Payload_v3 + module Payload_v3 = Payload_v3 + + module type S = S + + module Make (Io : Io.S) : S with module Io = Io +end diff --git a/vendors/irmin/src/irmin-pack/unix/dict.ml b/vendors/irmin/src/irmin-pack/unix/dict.ml new file mode 100644 index 0000000000000000000000000000000000000000..1d8bda0dcc979bb14aa53bb7a2eeadb506d30f34 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/dict.ml @@ -0,0 +1,97 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Dict_intf + +module Make (Fm : File_manager.S) = struct + module Fm = Fm + + type t = { + capacity : int; + cache : (string, int) Hashtbl.t; + index : (int, string) Hashtbl.t; + fm : Fm.t; + mutable last_refill_offset : int63; + } + + module File = struct + let append_exn t = Fm.Dict.append_exn (Fm.dict t.fm) + let offset t = Fm.Dict.end_offset (Fm.dict t.fm) + let read_to_string t = Fm.Dict.read_to_string (Fm.dict t.fm) + end + + type nonrec int32 = int32 [@@deriving irmin ~to_bin_string ~decode_bin] + + let append_string t v = + let len = Int32.of_int (String.length v) in + let buf = int32_to_bin_string len ^ v in + File.append_exn t buf + + (* Refill is only called once for a RW instance *) + let refill t = + let open Result_syntax in + let from = t.last_refill_offset in + let len = Int63.to_int Int63.Syntax.(File.offset t - from) in + t.last_refill_offset <- File.offset t; + let+ raw = File.read_to_string t ~off:from ~len in + let pos_ref = ref 0 in + let rec aux n = + if !pos_ref >= len then () + else + let v = decode_bin_int32 raw pos_ref in + let len = Int32.to_int v in + let v = String.sub raw !pos_ref len in + pos_ref := !pos_ref + len; + Hashtbl.add t.cache v n; + Hashtbl.add t.index n v; + (aux [@tailcall]) (n + 1) + in + (aux [@tailcall]) (Hashtbl.length t.cache) + + let index t v = + [%log.debug "[dict] index %S" v]; + try Some (Hashtbl.find t.cache v) + with Not_found -> + let id = Hashtbl.length t.cache in + if id > t.capacity then None + else ( + append_string t v; + Hashtbl.add t.cache v id; + Hashtbl.add t.index id v; + Some id) + + let find t id = + [%log.debug "[dict] find %d" id]; + let v = try Some (Hashtbl.find t.index id) with Not_found -> None in + v + + let default_capacity = 100_000 + + let v fm = + let open Result_syntax in + let cache = Hashtbl.create 997 in + let index = Hashtbl.create 997 in + let last_refill_offset = Int63.zero in + let t = + { capacity = default_capacity; index; cache; fm; last_refill_offset } + in + let* () = refill t in + Fm.register_dict_consumer fm ~after_reload:(fun () -> refill t); + Ok t + + let close _ = () +end diff --git a/vendors/irmin/src/irmin-pack/unix/dict.mli b/vendors/irmin/src/irmin-pack/unix/dict.mli new file mode 100644 index 0000000000000000000000000000000000000000..061578cb0f6d718e57e329d8f3606905ce1575c1 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/dict.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Dict_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/unix/dict_intf.ml b/vendors/irmin/src/irmin-pack/unix/dict_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..67673624344d0c32446da1e3f544364fa0153c5f --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/dict_intf.ml @@ -0,0 +1,32 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + module Fm : File_manager.S + + type t + + val find : t -> int -> string option + val index : t -> string -> int option + val v : Fm.t -> (t, [> Fm.Io.read_error ]) result + val close : t -> unit +end + +module type Sigs = sig + module type S = S + + module Make (Fm : File_manager.S) : S with module Fm = Fm +end diff --git a/vendors/irmin/src/irmin-pack/unix/dispatcher.ml b/vendors/irmin/src/irmin-pack/unix/dispatcher.ml new file mode 100644 index 0000000000000000000000000000000000000000..5f716c7efd764a8dd643e4ce25bb5739b7202926 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/dispatcher.ml @@ -0,0 +1,249 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +include Dispatcher_intf +module Payload = Control_file.Latest_payload +module Intmap = Map.Make (Int63) + +(* The following [with module Io = Io.Unix] forces unix *) +module Make (Fm : File_manager.S with module Io = Io.Unix) : + S with module Fm = Fm = struct + module Fm = Fm + module Io = Fm.Io + module Suffix = Fm.Suffix + module Mapping_file = Mapping_file.Make (Fm.Errs) + module Errs = Fm.Errs + module Control = Fm.Control + + let read_suffix = ref 0 + let read_prefix = ref 0 + (*TODO move them in stats*) + + type mapping_value = { poff : int63; len : int } + (** [poff] is a prefix offset (i.e. an offset in the prefix file), [len] is + the length of the chunk starting at [poff]. *) + + type mapping = mapping_value Intmap.t + + type t = { fm : Fm.t; mutable mapping : mapping; root : string } + (** [mapping] is a map from global offset to (offset,len) pairs in the prefix + file *) + + let load_mapping io = + let open Result_syntax in + let open Int63 in + let open Int63.Syntax in + let mapping = ref Intmap.empty in + let poff = ref zero in + let f ~off ~len = + mapping := Intmap.add off { poff = !poff; len } !mapping; + poff := !poff + of_int len + in + let* () = Mapping_file.iter io f in + Ok !mapping + + let reload t = + let open Result_syntax in + let* mapping = + match Fm.mapping t.fm with + | None -> Ok Intmap.empty + | Some io -> load_mapping io + in + t.mapping <- mapping; + Ok () + + let v ~root fm = + let open Result_syntax in + let t = { fm; mapping = Intmap.empty; root } in + Fm.register_mapping_consumer fm ~after_reload:(fun () -> reload t); + let* () = reload t in + Ok t + + let entry_offset_suffix_start t = + let pl = Control.payload (Fm.control t.fm) in + match pl.status with + | Payload.From_v1_v2_post_upgrade _ + | From_v3_used_non_minimal_indexing_strategy | From_v3_no_gc_yet -> + Int63.zero + | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14 + | T15 -> + assert false + | From_v3_gced { entry_offset_suffix_start; _ } -> entry_offset_suffix_start + + (* The suffix only know the real offsets, it is in the dispatcher that global + offsets are translated into real ones (i.e. in prefix or suffix offsets). *) + let end_offset t = + let open Int63.Syntax in + Suffix.end_offset (Fm.suffix t.fm) + entry_offset_suffix_start t + + (* Adjust the read in suffix, as the global offset [off] is + [off] = [entry_offset_suffix_start] + [suffix_offset]. *) + let suffix_off_of_offset t off = + let open Int63.Syntax in + let entry_offset_suffix_start = entry_offset_suffix_start t in + off - entry_offset_suffix_start + + let offset_of_suffix_off t suffix_off = + let open Int63.Syntax in + let entry_offset_suffix_start = entry_offset_suffix_start t in + suffix_off + entry_offset_suffix_start + + (* Find the last chunk which is before [off_start] (or at [off_start]). If no + chunk found, then the entry was possibly gced (case 1). If [off_start] is + after the entry's chunk then the entry was possibly gced (case 2). Note + that for these two cases we cannot distinguished between trying to read a + gced entry, or doing an invalid read. We expose two [read_exn] functions + and we handled this upstream. *) + let chunk_of_off_exn mapping off_start = + let open Int63 in + let open Int63.Syntax in + match + Intmap.find_last_opt + (fun chunk_off_start -> chunk_off_start <= off_start) + mapping + with + | None -> + (* Case 1: The entry if before the very first chunk (or there are no + chunks). Possibly the entry was gced. *) + let s = + Fmt.str "offset %a is before the first chunk, or the prefix is empty" + Int63.pp off_start + in + raise (Errors.Pack_error (`Invalid_read_of_gced_object s)) + | Some (chunk_off_start, chunk) -> + assert (chunk_off_start <= off_start); + let chunk_len = chunk.len in + let chunk_off_end = chunk_off_start + of_int chunk_len in + + (* Case 2: The entry starts after the chunk. Possibly the entry was + gced. *) + (if chunk_off_end <= off_start then + let s = + Fmt.str + "offset %a is supposed to be contained in chunk \ + (off=%a,poff=%a,len=%d) but starts after chunk" + Int63.pp off_start Int63.pp chunk_off_start Int63.pp chunk.poff + chunk.len + in + raise (Errors.Pack_error (`Invalid_read_of_gced_object s))); + + let shift_in_chunk = off_start - chunk_off_start in + let max_entry_len = of_int chunk_len - shift_in_chunk in + + (chunk, shift_in_chunk, max_entry_len) + + (* After we find the chunk of an entry, we check that a read is possible in the + chunk. If it's not, this is always an invalid read. *) + let poff_of_entry_exn mapping ~off ~len = + let chunk, shift_in_chunk, max_entry_len = chunk_of_off_exn mapping off in + + (* Case 3: The entry ends after the chunk *) + let open Int63 in + let open Int63.Syntax in + (if of_int len > max_entry_len then + let s = + Fmt.str + "entry (off=%a, len=%d) is supposed to be contained in chunk \ + (poff=%a,len=%d) and starting at %a but is larger than it can be\n\ + \ contained in chunk" Int63.pp off len Int63.pp chunk.poff chunk.len + Int63.pp shift_in_chunk + in + raise (Errors.Pack_error (`Invalid_prefix_read s))); + + (* Case 4: Success *) + chunk.poff + shift_in_chunk + + let get_prefix fm = + match Fm.prefix fm with + | Some prefix -> prefix + | None -> raise (Errors.Pack_error (`Invalid_prefix_read "no prefix found")) + + let read_exn t ~off ~len buf = + let open Int63.Syntax in + let entry_offset_suffix_start = entry_offset_suffix_start t in + if off >= entry_offset_suffix_start then ( + incr read_suffix; + let suffix_off = suffix_off_of_offset t off in + try Suffix.read_exn (Fm.suffix t.fm) ~off:suffix_off ~len buf + with e -> + let to_int = Int63.to_int in + Fmt.epr "\n%!"; + Fmt.epr "exception!\n%!"; + Fmt.epr "%#d %#d %#d %#d\n%!" (to_int off) len + (to_int entry_offset_suffix_start) + (to_int @@ end_offset t); + Fmt.epr "\n%!"; + raise e) + else ( + incr read_prefix; + let poff = poff_of_entry_exn t.mapping ~off ~len in + let prefix = get_prefix t.fm in + Io.read_exn prefix ~off:poff ~len buf; + ()) + + let read_in_prefix_and_suffix_exn t ~off ~len buf = + let ( -- ) a b = a - b in + let open Int63.Syntax in + let entry_offset_suffix_start = entry_offset_suffix_start t in + if + off < entry_offset_suffix_start + && off + Int63.of_int len > entry_offset_suffix_start + then ( + let read_in_prefix = entry_offset_suffix_start - off |> Int63.to_int in + read_exn t ~off ~len:read_in_prefix buf; + let read_in_suffix = len -- read_in_prefix in + let buf_suffix = Bytes.create read_in_suffix in + read_exn t ~off:entry_offset_suffix_start ~len:read_in_suffix buf_suffix; + Bytes.blit buf_suffix 0 buf read_in_prefix read_in_suffix) + else read_exn t ~off ~len buf + + let read_if_not_gced t ~off ~len buf = + try + read_exn t ~off ~len buf; + true + with Errors.Pack_error (`Invalid_read_of_gced_object _) -> false + + let read_at_most_from_suffix_exn t ~off ~len buf = + let bytes_after_off = Int63.sub (end_offset t) off in + let len = + let open Int63.Syntax in + if bytes_after_off < Int63.of_int len then Int63.to_int bytes_after_off + else len + in + let suffix_off = suffix_off_of_offset t off in + Suffix.read_exn (Fm.suffix t.fm) ~off:suffix_off ~len buf; + len + + let read_at_most_from_prefix_exn t ~off ~len buf = + let chunk, shift_in_chunk, max_entry_len = chunk_of_off_exn t.mapping off in + let fm = t.fm in + let open Int63 in + let open Int63.Syntax in + let min a b = if a < b then a else b in + let len = min max_entry_len (of_int len) |> to_int in + let poff = chunk.poff + shift_in_chunk in + let prefix = get_prefix fm in + Io.read_exn prefix ~off:poff ~len buf; + len + + let read_at_most_exn t ~off ~len buf = + let open Int63.Syntax in + let entry_offset_suffix_start = entry_offset_suffix_start t in + if off >= entry_offset_suffix_start then + read_at_most_from_suffix_exn t ~off ~len buf + else read_at_most_from_prefix_exn t ~off ~len buf +end diff --git a/vendors/irmin/src/irmin-pack/unix/dispatcher.mli b/vendors/irmin/src/irmin-pack/unix/dispatcher.mli new file mode 100644 index 0000000000000000000000000000000000000000..db2f1f3a4b73e41313ae792472f258b1954b28f7 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/dispatcher.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Dispatcher_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/unix/dispatcher_intf.ml b/vendors/irmin/src/irmin-pack/unix/dispatcher_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..b4078a69fd9290311378d47cad7ba53a2ff84472 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/dispatcher_intf.ml @@ -0,0 +1,65 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +module type S = sig + module Fm : File_manager.S + + type t + + val v : root:string -> Fm.t -> (t, [> Fm.Errs.t ]) result + + val read_exn : t -> off:int63 -> len:int -> bytes -> unit + (** [read_exn] either reads in the prefix or the suffix file, depending on + [off]. See [Io.read_exn] for the arguments. If it tries to read a gced + object, an exception is raised. *) + + val read_at_most_exn : t -> off:int63 -> len:int -> bytes -> int + (** [read_at_most_exn] is similar to [read_exn] but if the end of file is + reached while reading [len] bytes, then only the available bytes are read. + No [`Read_out_of_bounds] error is raised. The number of bytes read are + returned. *) + + val end_offset : t -> int63 + (** [end_offset] is the end offsets of the pack entries, counting that the + prefix doesn't start at 0. It counts the entries not yet flushed from the + prefix. *) + + val read_if_not_gced : t -> off:int63 -> len:int -> bytes -> bool + (** Similar to [read_exn] but returns false if the object was gced, instead of + raising an expection. *) + + val offset_of_suffix_off : t -> int63 -> int63 + (** [offset_of_suffix_off t suffix_off] converts a suffix offset into a + (global) offset. *) + + val read_in_prefix_and_suffix_exn : t -> off:int63 -> len:int -> bytes -> unit + (** Simlar to [read_exn] but if [off + len] is greater than the end of the + prefix, it will read the remaining in the prefix. *) + + type mapping + + val load_mapping : Fm.Io.t -> (mapping, [> Fm.Errs.t ]) result + val poff_of_entry_exn : mapping -> off:int63 -> len:int -> int63 +end + +module type Sigs = sig + module type S = S + + module Make (Fm : File_manager.S with module Io = Io.Unix) : + S with module Fm = Fm +end diff --git a/vendors/irmin/src/irmin-pack/unix/dune b/vendors/irmin/src/irmin-pack/unix/dune new file mode 100644 index 0000000000000000000000000000000000000000..75896e19bd104cdb5a979e5218c534b333c3b9bf --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/dune @@ -0,0 +1,19 @@ +(library + (public_name irmin-pack.unix) + (name irmin_pack_unix) + (libraries + fmt + index + index.unix + irmin + irmin-pack + logs + lwt + lwt.unix + mtime + cmdliner + optint) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-pack/unix/errors.ml b/vendors/irmin/src/irmin-pack/unix/errors.ml new file mode 100644 index 0000000000000000000000000000000000000000..741851532ad5e7767559b230f151556a4ed55bd2 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/errors.ml @@ -0,0 +1,145 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +(** Finaliser for a function that returns a result and doesn't raise exceptions. + + If the finaliser fails, it is recommended to log the error. *) +let finalise finaliser f = + let res = f () in + finaliser res; + res + +type base_error = + [ `Double_close + | `File_exists of string + | `Invalid_parent_directory + | `No_such_file_or_directory + | `Not_a_file + | `Read_out_of_bounds + | `Invalid_argument + | `Decoding_error + | `Not_a_directory of string + | `Index_failure of string + | `Invalid_layout + | `Corrupted_legacy_file + | `Corrupted_mapping_file of string + | `Pending_flush + | `Rw_not_allowed + | `Migration_needed + | `Corrupted_control_file + | `Sys_error of string + | `V3_store_from_the_future + | `Gc_forbidden_during_batch + | `Unknown_major_pack_version of string + | `Only_minimal_indexing_strategy_allowed + | `Commit_key_is_dangling of string + | `Dangling_key of string + | `Gc_disallowed + | `Node_or_contents_key_is_indexed of string + | `Commit_parent_key_is_indexed of string + | `Gc_process_error of string + | `Corrupted_gc_result_file of string + | `Gc_process_died_without_result_file of string + | `Gc_forbidden_on_32bit_platforms + | `Invalid_prefix_read of string + | `Invalid_read_of_gced_object of string ] +[@@deriving irmin ~pp] +(** [base_error] is the type of most errors that can occur in a [result], except + for errors that have associated exceptions (see below) and backend-specific + errors (see {!Io_errors}). *) + +type closed_error = [ `Closed ] [@@deriving irmin ~pp] +type read_only_error = [ `Ro_not_allowed ] [@@deriving irmin ~pp] +type error = [ base_error | closed_error | read_only_error ] + +exception Pack_error of base_error +exception Closed = Irmin.Closed +exception RO_not_allowed = Irmin_pack.RO_not_allowed + +(** Error manager *) +module type S = sig + type t = error + + val pp : Format.formatter -> [< t ] -> unit + val raise_error : [< t ] -> 'a + val log_error : string -> [< t ] -> unit + val catch : (unit -> 'a) -> ('a, [> t ]) result + val raise_if_error : ('a, [< t ]) result -> 'a + val log_if_error : string -> (unit, [< t ]) result -> unit + val to_json_string : (int63, [< t ]) result -> string + val of_json_string : string -> (int63, [> t ]) result +end + +module Base : S with type t = error = struct + type t = error + + let pp ppf = function + | #read_only_error as e -> pp_read_only_error ppf e + | #closed_error as e -> pp_closed_error ppf e + | #base_error as e -> pp_base_error ppf e + + let raise_error = function + | #read_only_error -> raise RO_not_allowed + | #closed_error -> raise Closed + | #base_error as e -> raise (Pack_error e) + + let log_error context e = [%log.err "%s failed: %a" context pp e] + + let catch f = + try Ok (f ()) with + | Pack_error e -> Error (e : base_error :> [> t ]) + | RO_not_allowed -> Error `Ro_not_allowed + | Closed -> Error `Closed + + let raise_if_error = function Ok x -> x | Error e -> raise_error e + + let log_if_error context = function + | Ok _ -> () + | Error e -> log_error context e + + type err = Pack_error of base_error | Ro_not_allowed | Closed + [@@deriving irmin] + + let t_to_err = function + | #read_only_error -> Ro_not_allowed + | #closed_error -> Closed + | #base_error as e -> Pack_error e + + let err_to_t = function + | Closed -> `Closed + | Ro_not_allowed -> `Ro_not_allowed + | Pack_error e -> (e : base_error :> [> t ]) + + let err_result = Irmin.Type.(result int63 err_t) + + let to_json_string result = + let convert = Result.map_error t_to_err in + convert result |> Irmin.Type.to_json_string err_result + + let of_json_string string = + match (Irmin.Type.of_json_string err_result) string with + | Error (`Msg _) -> Error `Decoding_error + | Ok result -> Result.map_error err_to_t result +end + +let () = + Printexc.register_printer (function + | Pack_error e -> Some (Fmt.str "Pack_error: %a" pp_base_error e) + | RO_not_allowed -> Some "RO_not_allowed" + | Closed -> Some "Closed" + | _ -> None) diff --git a/vendors/irmin/src/irmin-pack/unix/errors_base.ml b/vendors/irmin/src/irmin-pack/unix/errors_base.ml new file mode 100644 index 0000000000000000000000000000000000000000..1feae0b433674aabe63530752c24e7f6c2c0c242 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/errors_base.ml @@ -0,0 +1,62 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type base_error = + [ `Double_close + | `File_exists of string + | `Invalid_parent_directory + | `No_such_file_or_directory + | `Not_a_file + | `Read_on_closed + | `Read_out_of_bounds + | `Write_on_closed + | `Invalid_argument + | `Decoding_error + | `Not_a_directory of string + | `Index_failure of string + | `Invalid_layout + | `Corrupted_legacy_file + | `Pending_flush + | `Rw_not_allowed + | `Migration_needed + | `Corrupted_control_file + | `Sys_error of string + | `V3_store_from_the_future + | `Gc_forbidden_during_batch + | `Unknown_major_pack_version of string + | `Only_minimal_indexing_strategy_allowed + | `Commit_key_is_indexed_and_dangling of string + | `Dangling_key of string + | `Gc_disallowed + | `Node_or_contents_key_is_indexed of string + | `Commit_parent_key_is_indexed of string + | `Gc_process_error of string + | `Corrupted_gc_result_file of string + | `Gc_process_died_without_result_file of string + | `Gc_forbidden_on_32bit_platforms ] +[@@deriving irmin ~pp] +(** [base_error] is the type of most errors that can occur in a [result], except + [`Io_misc] which depends on the Io module used, and except [`Ro_not_allowed] + which has a dedicated exception. *) + +exception Pack_error of base_error + +let () = + Printexc.register_printer (function + | Pack_error e -> Some (Fmt.str "Pack_error: %a" pp_base_error e) + | _ -> None) + +exception RO_not_allowed = Irmin_pack.RO_not_allowed diff --git a/vendors/irmin/src/irmin-pack/unix/ext.ml b/vendors/irmin/src/irmin-pack/unix/ext.ml new file mode 100644 index 0000000000000000000000000000000000000000..4a62bd8de9ef3223dc0165f54f57c28f1b956f64 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/ext.ml @@ -0,0 +1,744 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module Maker (Config : Conf.S) = struct + type endpoint = unit + + include Pack_key.Store_spec + + module Make (Schema : Irmin.Schema.Extended) = struct + open struct + module P = Schema.Path + module M = Schema.Metadata + module C = Schema.Contents + module B = Schema.Branch + end + + module H = Schema.Hash + module Index = Pack_index.Make (H) + module Io = Io.Unix + module Errs = Io_errors.Make (Io) + module Control = Control_file.Make (Io) + module Aof = Append_only_file.Make (Io) + module File_manager = File_manager.Make (Control) (Aof) (Aof) (Index) (Errs) + module Dict = Dict.Make (File_manager) + module Dispatcher = Dispatcher.Make (File_manager) + module XKey = Pack_key.Make (H) + + module X = struct + module Hash = H + + type 'a value = { hash : H.t; kind : Pack_value.Kind.t; v : 'a } + [@@deriving irmin] + + module Contents = struct + module Pack_value = Pack_value.Of_contents (Config) (H) (XKey) (C) + + module CA = + Pack_store.Make (File_manager) (Dict) (Dispatcher) (H) (Pack_value) + (Errs) + + include Irmin.Contents.Store_indexable (CA) (H) (C) + end + + module Node = struct + module Value = Schema.Node (XKey) (XKey) + + module CA = struct + module Inter = + Irmin_pack.Inode.Make_internal (Config) (H) (XKey) (Value) + + module Pack' = + Pack_store.Make (File_manager) (Dict) (Dispatcher) (H) (Inter.Raw) + (Errs) + + include Inode.Make_persistent (H) (Value) (Inter) (Pack') + end + + include + Irmin.Node.Generic_key.Store (Contents) (CA) (H) (CA.Val) (M) (P) + end + + module Node_portable = Node.CA.Val.Portable + + module Schema = struct + include Schema + module Node = Node + end + + module Commit = struct + module Value = struct + include Schema.Commit (Node.Key) (XKey) + module Info = Schema.Info + + type hash = Hash.t [@@deriving irmin] + end + + module Pack_value = Pack_value.Of_commit (H) (XKey) (Value) + + module CA = + Pack_store.Make (File_manager) (Dict) (Dispatcher) (H) (Pack_value) + (Errs) + + include + Irmin.Commit.Generic_key.Store (Schema.Info) (Node) (CA) (H) (Value) + end + + module Commit_portable = struct + module Hash_key = Irmin.Key.Of_hash (Hash) + include Schema.Commit (Hash_key) (Hash_key) + + let of_commit : Commit.Value.t -> t = + fun t -> + let info = Commit.Value.info t + and node = Commit.Value.node t |> XKey.to_hash + and parents = Commit.Value.parents t |> List.map XKey.to_hash in + v ~info ~node ~parents + + module Info = Schema.Info + + type hash = Hash.t [@@deriving irmin] + end + + module Branch = struct + module Key = B + module Val = XKey + module AW = Atomic_write.Make_persistent (Key) (Val) + include Atomic_write.Closeable (AW) + + let v ?fresh ?readonly path = + AW.v ?fresh ?readonly path >|= make_closeable + end + + module Slice = Irmin.Backend.Slice.Make (Contents) (Node) (Commit) + module Remote = Irmin.Backend.Remote.None (Commit.Key) (B) + + module Gc = Gc.Make (struct + module Fm = File_manager + module Errs = Errs + module Dict = Dict + module Dispatcher = Dispatcher + module Hash = Schema.Hash + module Node_value = Node.CA.Inter.Val + module Node_store = Node.CA + module Commit_value = Commit.Value + module Commit_store = Commit.CA + + type hash = Node_value.hash + type key = Node_value.node_key [@@deriving irmin] + end) + + type during_gc = { + next_generation : int; + task : Io.task; + unlink : bool; + offset : int63; + } + + module Repo = struct + type t = { + config : Irmin.Backend.Conf.t; + contents : read Contents.CA.t; + node : read Node.CA.t; + commit : read Commit.CA.t; + branch : Branch.t; + fm : File_manager.t; + dict : Dict.t; + dispatcher : Dispatcher.t; + mutable during_batch : bool; + mutable during_gc : during_gc option; + } + + let pp_key = Irmin.Type.pp XKey.t + let contents_t t : 'a Contents.t = t.contents + let node_t t : 'a Node.t = (contents_t t, t.node) + let commit_t t : 'a Commit.t = (node_t t, t.commit) + let branch_t t = t.branch + let config t = t.config + + let batch t f = + t.during_batch <- true; + let contents = Contents.CA.cast t.contents in + let node = Node.CA.Pack.cast t.node in + let commit = Commit.CA.cast t.commit in + let contents : 'a Contents.t = contents in + let node : 'a Node.t = (contents, node) in + let commit : 'a Commit.t = (node, commit) in + let on_success res = + t.during_batch <- false; + File_manager.flush t.fm |> Errs.raise_if_error; + Lwt.return res + in + let on_fail exn = + t.during_batch <- false; + [%log.info + "[pack] batch failed. calling flush. (%s)" + (Printexc.to_string exn)]; + let () = + match File_manager.flush t.fm with + | Ok () -> () + | Error err -> + [%log.err + "[pack] batch failed and flush failed. Silencing flush \ + fail. (%a)" + Errs.pp err] + in + (* Kill gc process in at_exit. *) + raise exn + in + Lwt.try_bind (fun () -> f contents node commit) on_success on_fail + + let v config = + let root = Irmin_pack.Conf.root config in + let fm = + let readonly = Irmin_pack.Conf.readonly config in + if readonly then File_manager.open_ro config |> Errs.raise_if_error + else + let fresh = Irmin_pack.Conf.fresh config in + match (Io.classify_path root, fresh) with + | `No_such_file_or_directory, _ -> + File_manager.create_rw ~overwrite:false config + |> Errs.raise_if_error + | `Directory, true -> + File_manager.create_rw ~overwrite:true config + |> Errs.raise_if_error + | `Directory, false -> + File_manager.open_rw config |> Errs.raise_if_error + | (`File | `Other), _ -> Errs.raise_error (`Not_a_directory root) + in + let dict = Dict.v fm |> Errs.raise_if_error in + let dispatcher = Dispatcher.v ~root fm |> Errs.raise_if_error in + let contents = Contents.CA.v ~config ~fm ~dict ~dispatcher in + let node = Node.CA.v ~config ~fm ~dict ~dispatcher in + let commit = Commit.CA.v ~config ~fm ~dict ~dispatcher in + let+ branch = + let root = Conf.root config in + let fresh = Conf.fresh config in + let readonly = Conf.readonly config in + let path = Irmin_pack.Layout.V3.branch ~root in + Branch.v ~fresh ~readonly path + in + let during_batch = false in + let during_gc = None in + { + config; + contents; + node; + commit; + branch; + fm; + dict; + during_batch; + during_gc; + dispatcher; + } + + let close t = + (* Step 1 - Kill the gc process if it is running *) + let () = + match t.during_gc with + | Some { task; _ } -> + Io.cancel task; + t.during_gc <- None + | None -> () + in + (* Step 2 - Close the files *) + let () = File_manager.close t.fm |> Errs.raise_if_error in + Branch.close t.branch >>= fun () -> + (* Step 3 - Close the in-memory abstractions *) + Dict.close t.dict; + Contents.CA.close (contents_t t) >>= fun () -> + Node.CA.close (snd (node_t t)) >>= fun () -> + Commit.CA.close (snd (commit_t t)) + + let flush_with_hook ~hook t = + File_manager.flush ~hook t.fm |> Errs.raise_if_error + + let reload_with_hook ~hook t = + File_manager.reload ~hook t.fm |> Errs.raise_if_error + + let flush t = File_manager.flush ?hook:None t.fm |> Errs.raise_if_error + let reload t = File_manager.reload t.fm |> Errs.raise_if_error + + module Gc = struct + let unlink_result_file ~root ~generation = + let result_file = + Irmin_pack.Layout.V3.gc_result ~root ~generation + in + match Io.unlink result_file with + | Ok () -> () + | Error (`Sys_error msg as err) -> + if msg <> Fmt.str "%s: No such file or directory" result_file + then + [%log.warn + "Unlinking temporary files from previous failed gc. Failed \ + with error %a" + Errs.pp err] + + let start ~unlink t commit_key = + let open Result_syntax in + [%log.info "GC: Starting on %a" pp_key commit_key]; + let* () = + if t.during_batch then Error `Gc_forbidden_during_batch else Ok () + in + let* commit_key = + let state : _ Irmin_pack.Pack_key.state = + Irmin_pack.Pack_key.inspect commit_key + in + match state with + | Direct _ -> Ok commit_key + | Indexed h -> ( + match Commit.CA.index_direct_with_kind t.commit h with + | None -> + Error + (`Commit_key_is_dangling + (Irmin.Type.to_string XKey.t commit_key)) + | Some (k, _kind) -> Ok k) + in + let offset = + let state : _ Irmin_pack.Pack_key.state = + Irmin_pack.Pack_key.inspect commit_key + in + match state with + | Direct x -> x.offset + | Indexed _ -> assert false + in + let root = Conf.root t.config in + let* () = + if not (File_manager.gc_allowed t.fm) then Error `Gc_disallowed + else Ok () + in + let current_generation = File_manager.generation t.fm in + let next_generation = current_generation + 1 in + (* Unlink next gc's result file, in case it is on disk, for instance + after a failed gc. *) + unlink_result_file ~root ~generation:next_generation; + let task = + Io.async (fun () -> + let (_ : int63) = + Gc.run_and_output_result root commit_key + ~generation:next_generation + in + ()) + in + t.during_gc <- Some { next_generation; task; unlink; offset }; + Ok () + + let open_new_suffix ~root ~generation ~end_offset = + let open Result_syntax in + let path = Irmin_pack.Layout.V3.suffix ~root ~generation in + (* As the new suffix is necessarily in V3, the dead_header_size is + 0. *) + let dead_header_size = 0 in + let auto_flush_threshold = 1_000_000 in + let suffix_ref = ref None in + let auto_flush_callback () = + match !suffix_ref with + | None -> assert false + | Some x -> Aof.flush x |> Errs.raise_if_error + in + let* suffix = + Aof.open_rw ~path ~end_offset ~dead_header_size + ~auto_flush_callback ~auto_flush_threshold + in + suffix_ref := Some suffix; + Ok suffix + + let transfer_latest_newies ~generation ~right_start_offset + ~copy_end_offset ~root t = + [%log.debug "Gc in main: transfer latest newies"]; + let open Result_syntax in + let open Int63.Syntax in + let old_end_offset = Dispatcher.end_offset t.dispatcher in + let remaining = old_end_offset - copy_end_offset in + (* When opening the suffix in append_only we need to provide a + (real) suffix offset, computed from the global ones. *) + let suffix_end_offset = copy_end_offset - right_start_offset in + let* new_suffix = + open_new_suffix ~root ~generation ~end_offset:suffix_end_offset + in + Errors.finalise (fun _ -> + Aof.close new_suffix + |> Errs.log_if_error "GC: Close suffix after copy latest newies") + @@ fun () -> + let buffer = Bytes.create 8192 in + let read_exn = Dispatcher.read_exn t.dispatcher in + let append_exn = Aof.append_exn new_suffix in + let flush_and_raise () = + Aof.flush new_suffix |> Errs.raise_if_error + in + let* () = + Errs.catch (fun () -> + Gc.transfer_append_exn ~read_exn ~append_exn + ~off:copy_end_offset ~len:remaining buffer; + flush_and_raise ()) + in + Ok old_end_offset + + let swap_and_purge ~generation ~right_start_offset ~right_end_offset t + = + let open Result_syntax in + let* () = + File_manager.swap t.fm ~generation ~right_start_offset + ~right_end_offset + in + (* No need to purge dict here, as it is global to the store. *) + (* No need to purge index here. It is global too, but some hashes may + not point to valid offsets anymore. Pack_store will just say that + such keys are not member of the store. *) + Contents.CA.purge_lru t.contents; + Node.CA.purge_lru t.node; + Commit.CA.purge_lru t.commit; + [%log.info "GC: end"]; + Ok () + + let pp_status = Irmin.Type.pp Io.status_t + let pp_gc_error = Irmin.Type.pp File_manager.read_gc_output_error_t + + let unlink_all ~root ~generation = + let result = + let open Result_syntax in + (* Unlink previous suffix. *) + let suffix = + Irmin_pack.Layout.V3.suffix ~root ~generation:(generation - 1) + in + let* () = Io.unlink suffix in + let* () = + if generation >= 2 then + (* Unlink previous prefix. *) + let prefix = + Irmin_pack.Layout.V3.prefix ~root + ~generation:(generation - 1) + in + let* () = Io.unlink prefix in + (* Unlink previous mapping. *) + let mapping = + Irmin_pack.Layout.V3.mapping ~root + ~generation:(generation - 1) + in + let* () = Io.unlink mapping in + Ok () + else Ok () + in + (* Unlink current gc's result.*) + let result = Irmin_pack.Layout.V3.gc_result ~root ~generation in + Io.unlink result + in + match result with + | Error e -> + [%log.warn + "Unlinking temporary files after gc, failed with error %a" + Errs.pp e] + | Ok () -> () + + let gc_errors status gc_output = + let extend_error s = function + | `Gc_process_error str -> + `Gc_process_error (Fmt.str "%s %s" s str) + | `Corrupted_gc_result_file str -> + `Gc_process_died_without_result_file (Fmt.str "%s %s" s str) + in + match (status, gc_output) with + | `Failure s, Error e -> Error (extend_error s e) + | `Cancelled, Error e -> Error (extend_error "cancelled" e) + | `Success, Error e -> Error (extend_error "success" e) + | `Cancelled, Ok _ -> Error (`Gc_process_error "cancelled") + | `Failure s, Ok _ -> Error (`Gc_process_error s) + | `Success, Ok _ -> assert false + | `Running, _ -> assert false + + let finalise ?hook ~wait t = + match t.during_gc with + | None -> Lwt.return_ok false + | Some { next_generation; task; unlink; offset } -> ( + let go status = + let* () = + match hook with + | Some h -> h `Before_latest_newies + | None -> Lwt.return_unit + in + let root = Conf.root t.config in + let gc_output = + File_manager.read_gc_output ~root + ~generation:next_generation + in + let result = + let open Result_syntax in + match (status, gc_output) with + | `Success, Ok copy_end_offset -> + let* new_suffix_end_offset = + transfer_latest_newies ~generation:next_generation + ~right_start_offset:offset ~copy_end_offset ~root t + in + let* () = + swap_and_purge ~generation:next_generation + ~right_start_offset:offset + ~right_end_offset:new_suffix_end_offset t + in + if unlink then + unlink_all ~root ~generation:next_generation; + Ok true + | _ -> gc_errors status gc_output + in + t.during_gc <- None; + Lwt.return result + in + if t.during_batch then + Lwt.return_error `Gc_forbidden_during_batch + else + match wait with + | false -> ( + match Io.status task with + | `Running -> Lwt.return_ok false + | status -> go status) + | true -> + let* status = Io.await task in + go status) + + let start_or_wait ~unlink ~throttle t commit_key = + let open Lwt_result.Syntax in + match (t.during_gc, throttle) with + | None, _ -> + let* () = start ~unlink t commit_key |> Lwt.return in + Lwt.return_ok true + | Some _, `Block -> + (* The result of finalise is not useful here: if there is no + running gc, then finalise returns false, otherwise its waits + and returns true. *) + let* (_ : bool) = finalise ~wait:true t in + let* () = start ~unlink t commit_key |> Lwt.return in + Lwt.return_ok true + | Some _, `Skip -> Lwt.return_ok false + + let start_exn ?(unlink = true) ~throttle t commit_key = + let* result = start_or_wait ~unlink ~throttle t commit_key in + match result with + | Ok launched -> Lwt.return launched + | Error e -> Errs.raise_error e + + let finalise_exn ?hook ?(wait = false) t = + let* result = finalise ?hook ~wait t in + match result with + | Ok waited -> Lwt.return waited + | Error e -> Errs.raise_error e + end + end + end + + let integrity_check ?ppf ~auto_repair t = + let module Checks = Checks.Index (Index) in + let contents = X.Repo.contents_t t in + let nodes = X.Repo.node_t t |> snd in + let commits = X.Repo.commit_t t |> snd in + let check ~kind ~offset ~length k = + match kind with + | `Contents -> X.Contents.CA.integrity_check ~offset ~length k contents + | `Node -> X.Node.CA.integrity_check ~offset ~length k nodes + | `Commit -> X.Commit.CA.integrity_check ~offset ~length k commits + in + let index = File_manager.index t.fm in + Checks.integrity_check ?ppf ~auto_repair ~check index + + include Irmin.Of_backend (X) + + let integrity_check_inodes ?heads t = + [%log.debug "Check integrity for inodes"]; + let counter, (_, progress_nodes, progress_commits) = + Utils.Object_counter.start () + in + let errors = ref [] in + let nodes = X.Repo.node_t t |> snd in + let pred_node repo key = + Lwt.catch + (fun () -> Repo.default_pred_node repo key) + (fun _ -> + errors := "Error in repo iter" :: !errors; + Lwt.return []) + in + + let node k = + progress_nodes (); + X.Node.CA.integrity_check_inodes nodes k >|= function + | Ok () -> () + | Error msg -> errors := msg :: !errors + in + let commit _ = + progress_commits (); + Lwt.return_unit + in + let* heads = + match heads with None -> Repo.heads t | Some m -> Lwt.return m + in + let hashes = List.map (fun x -> `Commit (Commit.key x)) heads in + let+ () = + Repo.iter ~cache_size:1_000_000 ~min:[] ~max:hashes ~pred_node ~node + ~commit t + in + Utils.Object_counter.finalise counter; + let pp_commits = Fmt.list ~sep:Fmt.comma Commit.pp_hash in + if !errors = [] then + Fmt.kstr (fun x -> Ok (`Msg x)) "Ok for heads %a" pp_commits heads + else + Fmt.kstr + (fun x -> Error (`Msg x)) + "Inconsistent inodes found for heads %a: %a" pp_commits heads + Fmt.(list ~sep:comma string) + !errors + + module Stats = struct + let pp_key = Irmin.Type.pp XKey.t + + let traverse_inodes ~dump_blob_paths_to commit repo = + let module Stats = Checks.Stats (struct + type nonrec step = step + + let step_t = step_t + + module Hash = Hash + end) in + let t = Stats.v () in + let pred_node repo k = + X.Node.find (X.Repo.node_t repo) k >|= function + | None -> Fmt.failwith "key %a not found" pp_key k + | Some v -> + let width = X.Node.Val.length v in + let nb_children = X.Node.CA.Val.nb_children v in + let preds = X.Node.CA.Val.pred v in + let () = + preds + |> List.map (function + | s, `Contents h -> (s, `Contents (XKey.to_hash h)) + | s, `Inode h -> (s, `Inode (XKey.to_hash h)) + | s, `Node h -> (s, `Node (XKey.to_hash h))) + |> Stats.visit_node t (XKey.to_hash k) ~width ~nb_children + in + List.rev_map + (function + | s, `Inode x -> + assert (s = None); + `Node x + | _, `Node x -> `Node x + | _, `Contents x -> `Contents x) + preds + in + (* We are traversing only one commit. *) + let pred_commit repo k = + X.Commit.find (X.Repo.commit_t repo) k >|= function + | None -> [] + | Some c -> + let node = X.Commit.Val.node c in + Stats.visit_commit t (XKey.to_hash node); + [ `Node node ] + in + let pred_contents _repo k = + Stats.visit_contents t (XKey.to_hash k); + Lwt.return [] + in + (* We want to discover all paths to a node, so we don't cache nodes + during traversal. *) + let* () = + Repo.breadth_first_traversal ~cache_size:0 ~pred_node ~pred_commit + ~pred_contents ~max:[ commit ] repo + in + Stats.pp_results ~dump_blob_paths_to t; + Lwt.return_unit + + let run ~dump_blob_paths_to ~commit repo = + Printexc.record_backtrace true; + let key = `Commit (Commit.key commit) in + traverse_inodes ~dump_blob_paths_to key repo + end + + let stats = Stats.run + let reload = X.Repo.reload + let flush = X.Repo.flush + let start_gc = X.Repo.Gc.start_exn + let finalise_gc = X.Repo.Gc.finalise_exn ?hook:None + let finalise_gc_with_hook = X.Repo.Gc.finalise_exn + + module Traverse_pack_file = Traverse_pack_file.Make (struct + module File_manager = File_manager + module Hash = H + module Index = Index + module Inode = X.Node.CA + module Dict = Dict + module Contents = X.Contents.Pack_value + module Commit = X.Commit.Pack_value + end) + + let traverse_pack_file = Traverse_pack_file.run + let test_traverse_pack_file = Traverse_pack_file.test + + module Snapshot = struct + include X.Node.CA.Snapshot + + type t = Inode of inode | Blob of Backend.Contents.Val.t + [@@deriving irmin] + + module S = Snapshot.Make (struct + module Hash = H + module Inode = X.Node.CA + module Contents_pack = X.Contents.CA + module Fm = File_manager + module Dispatcher = Dispatcher + end) + + include S + + module Export = struct + let iter ?on_disk repo f ~root_key = + [%log.debug "Iterate over a tree"]; + let contents = X.Repo.contents_t repo in + let nodes = X.Repo.node_t repo |> snd in + let export = S.Export.v repo.config contents nodes in + let f_contents x = f (Blob x) in + let f_nodes x = f (Inode x) in + match root_key with + | `Contents _ -> Fmt.failwith "[root_key] cannot be of type contents" + | `Node key -> + let* total = + Export.run ?on_disk export f_contents f_nodes + (key, Pack_value.Kind.Inode_v2_root) + in + Export.close export |> Errs.raise_if_error; + Lwt.return total + end + + let export = Export.iter + + module Import = struct + type process = Import.t + + let v ?on_disk repo = + let contents = X.Repo.contents_t repo in + let nodes = X.Repo.node_t repo |> snd in + let log_size = Conf.index_log_size repo.config in + Import.v ?on_disk log_size contents nodes + + let save_elt process elt = + match elt with + | Blob x -> Import.save_contents process x + | Inode x -> Import.save_inodes process x + + let close process repo = + flush repo; + Import.close process + end + end + end +end diff --git a/vendors/irmin/src/irmin-pack/unix/file_manager.ml b/vendors/irmin/src/irmin-pack/unix/file_manager.ml new file mode 100644 index 0000000000000000000000000000000000000000..c409ccb22ce920fa43b2eb0020e90ed9e0caf323 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/file_manager.ml @@ -0,0 +1,763 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include File_manager_intf +open Import +module Payload = Control_file.Latest_payload +include File_manager_intf + +let legacy_io_header_size = 16 + +module Make + (Control : Control_file.S with module Io = Io.Unix) + (Dict : Append_only_file.S with module Io = Control.Io) + (Suffix : Append_only_file.S with module Io = Control.Io) + (Index : Pack_index.S) + (Errs : Io_errors.S with module Io = Control.Io) = +struct + module Io = Control.Io + module Control = Control + module Dict = Dict + module Suffix = Suffix + module Index = Index + module Errs = Errs + module Prefix = Io + module Mapping = Io + + type after_reload_consumer = { after_reload : unit -> (unit, Errs.t) result } + type after_flush_consumer = { after_flush : unit -> unit } + + type t = { + dict : Dict.t; + control : Control.t; + mutable suffix : Suffix.t; + mutable prefix : Prefix.t option; + mutable mapping : Mapping.t option; + index : Index.t; + mutable mapping_consumers : after_reload_consumer list; + mutable dict_consumers : after_reload_consumer list; + mutable suffix_consumers : after_flush_consumer list; + indexing_strategy : Irmin_pack.Indexing_strategy.t; + use_fsync : bool; + root : string; + } + + let control t = t.control + let dict t = t.dict + let suffix t = t.suffix + let index t = t.index + let mapping t = t.mapping + let prefix t = t.prefix + + let close t = + let open Result_syntax in + let* () = Dict.close t.dict in + let* () = Control.close t.control in + let* () = Suffix.close t.suffix in + let* () = Option.might Mapping.close t.mapping in + let* () = Option.might Prefix.close t.prefix in + let+ () = Index.close t.index in + () + + let register_mapping_consumer t ~after_reload = + t.mapping_consumers <- { after_reload } :: t.mapping_consumers + + let register_dict_consumer t ~after_reload = + t.dict_consumers <- { after_reload } :: t.dict_consumers + + let register_suffix_consumer t ~after_flush = + t.suffix_consumers <- { after_flush } :: t.suffix_consumers + + let generation = function + | Payload.From_v1_v2_post_upgrade _ + | From_v3_used_non_minimal_indexing_strategy | From_v3_no_gc_yet -> + 0 + | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14 + | T15 -> + (* Unreachable *) + assert false + | From_v3_gced x -> x.generation + + (** Flush stages ************************************************************* + + The irmin-pack files are only mutated during calls to one of the 3 + following functions. Exceptions: + + - During [create] and [open_rw]. + - During a GC. + - When the branch store is modified. *) + + (** Flush stage 1 *) + let flush_dict t = + let open Result_syntax in + if Dict.empty_buffer t.dict then Ok () + else + let* () = + Stats.incr_fm_field Dict_flushes; + Dict.flush t.dict + in + let* () = if t.use_fsync then Dict.fsync t.dict else Ok () in + let* () = + let pl : Payload.t = Control.payload t.control in + let pl = { pl with dict_offset_end = Dict.end_offset t.dict } in + Control.set_payload t.control pl + in + let+ () = if t.use_fsync then Control.fsync t.control else Ok () in + () + + (** Flush stage 2 *) + let flush_suffix_and_its_deps ?hook t = + let open Result_syntax in + let* () = flush_dict t in + (match hook with Some h -> h `After_dict | None -> ()); + if Suffix.empty_buffer t.suffix then Ok () + else + let* () = + Stats.incr_fm_field Suffix_flushes; + Suffix.flush t.suffix + in + let* () = if t.use_fsync then Suffix.fsync t.suffix else Ok () in + let* () = + let pl : Payload.t = Control.payload t.control in + let status = + match pl.status with + | From_v1_v2_post_upgrade _ -> pl.status + | From_v3_gced _ -> pl.status + | From_v3_no_gc_yet -> + (* Using physical equality to test which indexing_strategy + we are using. Might not be great in the long term. *) + if t.indexing_strategy == Irmin_pack.Indexing_strategy.minimal + then pl.status + else ( + [%log.warn + "Updating the control file from [From_v3] to \ + [From_v3_used_non_minimal_indexing_strategy]. It won't be \ + possible to GC this irmin-pack store anymore."]; + Payload.From_v3_used_non_minimal_indexing_strategy) + | From_v3_used_non_minimal_indexing_strategy -> pl.status + | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 + | T14 | T15 -> + assert false + in + let pl = + { + pl with + entry_offset_suffix_end = Suffix.end_offset t.suffix; + status; + } + in + Control.set_payload t.control pl + in + let+ () = if t.use_fsync then Control.fsync t.control else Ok () in + List.iter (fun { after_flush } -> after_flush ()) t.suffix_consumers + + (** Flush stage 3 *) + let flush_index_and_its_deps ?hook t = + let open Result_syntax in + let* () = flush_suffix_and_its_deps ?hook t in + (match hook with Some h -> h `After_suffix | None -> ()); + let+ () = + Stats.incr_fm_field Index_flushes; + Index.flush ~with_fsync:t.use_fsync t.index + in + () + + (* Auto flushes *********************************************************** *) + + (** Is expected to be called by the dict when its append buffer is full so + that the file manager flushes. *) + let dict_requires_a_flush_exn t = + Stats.incr_fm_field Auto_dict; + flush_dict t |> Errs.raise_if_error + + (** Is expected to be called by the suffix when its append buffer is full so + that the file manager flushes. *) + let suffix_requires_a_flush_exn t = + Stats.incr_fm_field Auto_suffix; + flush_suffix_and_its_deps t |> Errs.raise_if_error + + (** Is expected to be called by the index when its append buffer is full so + that the dependendies of index are flushes. When the function returns, + index will flush itself. *) + let index_is_about_to_auto_flush_exn t = + Stats.incr_fm_field Auto_index; + flush_suffix_and_its_deps t |> Errs.raise_if_error + + (* Explicit flush ********************************************************* *) + + let flush ?hook t = + Stats.incr_fm_field Flush; + flush_index_and_its_deps ?hook t + + (* Constructors *********************************************************** *) + + let reopen_prefix t ~generation = + let open Result_syntax in + let* prefix1 = + let path = Irmin_pack.Layout.V3.prefix ~root:t.root ~generation in + [%log.debug "reload: generation changed, opening %s" path]; + Prefix.open_ ~readonly:true ~path + in + let prefix0 = t.prefix in + t.prefix <- Some prefix1; + match prefix0 with None -> Ok () | Some io -> Prefix.close io + + let reopen_mapping t ~generation = + let open Result_syntax in + let* mapping1 = + let path = Irmin_pack.Layout.V3.mapping ~root:t.root ~generation in + [%log.debug "reload: generation changed, opening %s" path]; + Mapping.open_ ~readonly:true ~path + in + let mapping0 = t.mapping in + t.mapping <- Some mapping1; + match mapping0 with None -> Ok () | Some io -> Mapping.close io + + let reopen_suffix t ~generation ~end_offset = + let open Result_syntax in + (* Invariant: reopen suffix is only called on V3 suffix files, for which + dead_header_size is 0. *) + let dead_header_size = 0 in + [%log.debug + "reopen_suffix gen:%d end_offset:%d\n%!" generation + (Int63.to_int end_offset)]; + let readonly = Suffix.readonly t.suffix in + let* suffix1 = + let path = Irmin_pack.Layout.V3.suffix ~root:t.root ~generation in + [%log.debug "reload: generation changed, opening %s" path]; + if readonly then Suffix.open_ro ~path ~end_offset ~dead_header_size + else + let auto_flush_threshold = + match Suffix.auto_flush_threshold t.suffix with + | None -> assert false + | Some x -> x + in + let cb () = suffix_requires_a_flush_exn t in + Suffix.open_rw ~path ~end_offset ~dead_header_size ~auto_flush_threshold + ~auto_flush_callback:cb + in + let suffix0 = t.suffix in + t.suffix <- suffix1; + Suffix.close suffix0 + + let only_open_after_gc ~generation ~path = + let open Result_syntax in + if generation = 0 then Ok None + else + let* t = Io.open_ ~path ~readonly:true in + Ok (Some t) + + let finish_constructing_rw config control ~make_dict ~make_suffix ~make_index + = + let open Result_syntax in + let root = Irmin_pack.Conf.root config in + let use_fsync = Irmin_pack.Conf.use_fsync config in + let indexing_strategy = Conf.indexing_strategy config in + let pl : Payload.t = Control.payload control in + let generation = + match pl.status with + | From_v1_v2_post_upgrade _ | From_v3_no_gc_yet + | From_v3_used_non_minimal_indexing_strategy -> + 0 + | From_v3_gced x -> x.generation + | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14 + | T15 -> + assert false + in + (* 1. Create a ref for dependency injections for auto flushes *) + let instance = ref None in + let get_instance () = + match !instance with + | None -> + [%log.warn + "%s: instance was accessed whilst None; this is unexpected during \ + normal node operation" + __FILE__]; + [%log.warn + "%s: the stack trace is %s" __FILE__ + Printexc.(get_callstack 20 |> raw_backtrace_to_string)]; + (* get_instance is used by the callback functions below; if we reach this point, a + callback was invoked whilst instance was None; it should be the case that we + can ignore the callback *) + assert false + | Some x -> x + in + (* 2. Open the other files *) + let* suffix = + let path = Irmin_pack.Layout.V3.suffix ~root ~generation in + let auto_flush_threshold = + Irmin_pack.Conf.suffix_auto_flush_threshold config + in + let cb () = suffix_requires_a_flush_exn (get_instance ()) in + make_suffix ~path ~auto_flush_threshold ~auto_flush_callback:cb + in + let* prefix = + let path = Irmin_pack.Layout.V3.prefix ~root ~generation in + only_open_after_gc ~generation ~path + in + let* mapping = + let path = Irmin_pack.Layout.V3.mapping ~root ~generation in + only_open_after_gc ~generation ~path + in + let* dict = + let path = Irmin_pack.Layout.V3.dict ~root in + let auto_flush_threshold = + Irmin_pack.Conf.dict_auto_flush_threshold config + in + let cb () = dict_requires_a_flush_exn (get_instance ()) in + make_dict ~path ~auto_flush_threshold ~auto_flush_callback:cb + in + let* index = + let log_size = Conf.index_log_size config in + let throttle = Conf.merge_throttle config in + let cb () = + (* when creating the index, the index may call flush_callback, see + https://github.com/mirage/irmin/issues/1963; so we can't assume that instance + is set to Some _ in get_instance(); instead, we check instance, and just ignore + the callback if the instance is None *) + match !instance with + | None -> () + | Some _ -> index_is_about_to_auto_flush_exn (get_instance ()) + in + (* [cb] will not be called during calls to [index.flush] because we will + use [~no_callback:()] *) + make_index ~flush_callback:cb ~readonly:false ~throttle ~log_size root + in + let t = + { + dict; + control; + suffix; + prefix; + mapping; + use_fsync; + index; + mapping_consumers = []; + dict_consumers = []; + suffix_consumers = []; + indexing_strategy; + root; + } + in + instance := Some t; + Ok t + + let create_control_file ~overwrite config pl = + let root = Irmin_pack.Conf.root config in + let path = Irmin_pack.Layout.V3.control ~root in + Control.create_rw ~path ~overwrite pl + + (* Reload ***************************************************************** *) + + let reload ?hook t = + let open Result_syntax in + let* () = Index.reload t.index in + (match hook with Some h -> h `After_index | None -> ()); + let pl0 = Control.payload t.control in + let* () = Control.reload t.control in + (match hook with Some h -> h `After_control | None -> ()); + let pl1 : Payload.t = Control.payload t.control in + if pl0 = pl1 then Ok () + else + (* Check if generation changed. If it did, reopen suffix, prefix and + mapping. *) + let* () = + let gen0 = generation pl0.status in + let gen1 = generation pl1.status in + if gen0 = gen1 then Ok () + else + let end_offset = pl1.entry_offset_suffix_end in + let* () = reopen_suffix t ~generation:gen1 ~end_offset in + let* () = reopen_mapping t ~generation:gen1 in + let* () = reopen_prefix t ~generation:gen1 in + Ok () + in + (* Update end offsets. This prevents the readonly instance to read data + flushed to disk by the readwrite, between calls to reload. *) + let* () = + Suffix.refresh_end_offset t.suffix pl1.entry_offset_suffix_end + in + (match hook with Some h -> h `After_suffix | None -> ()); + let* () = Dict.refresh_end_offset t.dict pl1.dict_offset_end in + let* () = + let res = + List.fold_left + (fun acc { after_reload } -> Result.bind acc after_reload) + (Ok ()) t.dict_consumers + in + (* The following dirty trick casts the result from + [read_error] to [ [>read_error] ]. *) + match res with Ok () -> Ok () | Error (#Errs.t as e) -> Error e + in + let* () = + let res = + List.fold_left + (fun acc { after_reload } -> Result.bind acc after_reload) + (Ok ()) t.mapping_consumers + in + (* The following dirty trick casts the result from + [read_error] to [ [>read_error] ]. *) + match res with Ok () -> Ok () | Error (#Errs.t as e) -> Error e + in + Ok () + + (* File creation ********************************************************** *) + + let create_rw ~overwrite config = + let open Result_syntax in + let root = Irmin_pack.Conf.root config in + let* () = + match (overwrite, Io.classify_path root) with + | _, (`File | `Other) -> Error (`Not_a_directory root) + | false, `Directory -> Error (`File_exists root) + | true, `Directory -> Ok () + | _, `No_such_file_or_directory -> Io.mkdir root + in + let* control = + let open Payload in + let status = From_v3_no_gc_yet in + let pl = + let z = Int63.zero in + { dict_offset_end = z; entry_offset_suffix_end = z; status } + in + create_control_file ~overwrite config pl + in + let make_dict = Dict.create_rw ~overwrite in + let make_suffix = Suffix.create_rw ~overwrite in + let make_index ~flush_callback ~readonly ~throttle ~log_size root = + (* [overwrite] is ignored for index *) + Index.v ~fresh:true ~flush_callback ~readonly ~throttle ~log_size root + in + finish_constructing_rw config control ~make_dict ~make_suffix ~make_index + + (* Open rw **************************************************************** *) + + let open_rw_with_control_file config = + let open Result_syntax in + let root = Irmin_pack.Conf.root config in + let* control = + let path = Irmin_pack.Layout.V3.control ~root in + Control.open_ ~readonly:false ~path + in + let pl : Payload.t = Control.payload control in + let* dead_header_size = + match pl.status with + | From_v1_v2_post_upgrade _ -> Ok legacy_io_header_size + | From_v3_gced _ -> + let indexing_strategy = Conf.indexing_strategy config in + (* Using physical equality to test which indexing_strategy + we are using. Might not be great in the long term. *) + if indexing_strategy == Irmin_pack.Indexing_strategy.minimal then Ok 0 + else Error `Only_minimal_indexing_strategy_allowed + | From_v3_no_gc_yet | From_v3_used_non_minimal_indexing_strategy -> Ok 0 + | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14 + | T15 -> + Error `V3_store_from_the_future + in + let make_dict = + let end_offset = pl.dict_offset_end in + Dict.open_rw ~end_offset ~dead_header_size + in + let make_suffix = + let end_offset = pl.entry_offset_suffix_end in + Suffix.open_rw ~end_offset ~dead_header_size + in + let make_index ~flush_callback ~readonly ~throttle ~log_size root = + Index.v ~fresh:false ~flush_callback ~readonly ~throttle ~log_size root + in + finish_constructing_rw config control ~make_dict ~make_suffix ~make_index + + let decode_int63 buf = Int63.decode ~off:0 buf + + let read_offset_from_legacy_file path = + let open Result_syntax in + (* Bytes 0-7 contains the offset. Bytes 8-15 contain the version. *) + let* io = Io.open_ ~path ~readonly:true in + Errors.finalise (fun _ -> + Io.close io |> Errs.log_if_error "FM: read_offset_from_legacy_file") + @@ fun () -> + let* s = Io.read_to_string io ~off:Int63.zero ~len:8 in + let x = decode_int63 s in + Ok x + + let read_version_from_legacy_file path = + let open Result_syntax in + (* Bytes 0-7 contains the offset. Bytes 8-15 contain the version. *) + let* io = Io.open_ ~path ~readonly:true in + Errors.finalise (fun _ -> + Io.close io |> Errs.log_if_error "FM: read_version_from_legacy_file") + @@ fun () -> + let off = Int63.of_int 8 in + let* s = Io.read_to_string io ~off ~len:8 in + match Version.of_bin s with + | Some x -> Ok x + | None -> Error `Corrupted_legacy_file + + let open_rw_migrate_from_v1_v2 config = + let open Result_syntax in + let root = Irmin_pack.Conf.root config in + let src = Irmin_pack.Layout.V1_and_v2.pack ~root in + let dst = Irmin_pack.Layout.V3.suffix ~root ~generation:0 in + let* entry_offset_suffix_end = read_offset_from_legacy_file src in + let* dict_offset_end = + let path = Irmin_pack.Layout.V3.dict ~root in + read_offset_from_legacy_file path + in + let* () = Io.move_file ~src ~dst in + let* control = + let open Payload in + let status = + From_v1_v2_post_upgrade + { entry_offset_at_upgrade_to_v3 = entry_offset_suffix_end } + in + let pl = { dict_offset_end; entry_offset_suffix_end; status } in + create_control_file ~overwrite:false config pl + in + let* () = Control.close control in + open_rw_with_control_file config + + let open_rw_no_control_file config = + let root = Irmin_pack.Conf.root config in + let suffix_path = Irmin_pack.Layout.V1_and_v2.pack ~root in + match Io.classify_path suffix_path with + | `Directory -> Error `Invalid_layout + | `No_such_file_or_directory | `Other -> Error `Invalid_layout + | `File -> open_rw_migrate_from_v1_v2 config + + let open_rw config = + let root = Irmin_pack.Conf.root config in + let no_migrate = Irmin_pack.Conf.no_migrate config in + match Io.classify_path root with + | `File | `Other -> Error (`Not_a_directory root) + | `No_such_file_or_directory -> Error `No_such_file_or_directory + | `Directory -> ( + let path = Irmin_pack.Layout.V3.control ~root in + match Io.classify_path path with + | `File -> open_rw_with_control_file config + | `No_such_file_or_directory -> + if no_migrate then Error `Migration_needed + else open_rw_no_control_file config + | `Directory | `Other -> Error `Invalid_layout) + + (* Open ro **************************************************************** *) + + let open_ro config = + let open Result_syntax in + let indexing_strategy = Conf.indexing_strategy config in + let root = Irmin_pack.Conf.root config in + let use_fsync = Irmin_pack.Conf.use_fsync config in + (* 1. Open the control file *) + let* control = + let path = Irmin_pack.Layout.V3.control ~root in + Control.open_ ~readonly:true ~path + (* If no control file, then check whether the store is in v1 or v2. *) + |> Result.map_error (function + | `No_such_file_or_directory -> + let pack = Irmin_pack.Layout.V1_and_v2.pack ~root in + if Io.classify_path pack = `File then `Migration_needed + else `No_such_file_or_directory + | error -> error) + in + let pl : Payload.t = Control.payload control in + let* dead_header_size = + match pl.status with + | From_v1_v2_post_upgrade _ -> Ok legacy_io_header_size + | From_v3_no_gc_yet | From_v3_gced _ + | From_v3_used_non_minimal_indexing_strategy -> + Ok 0 + | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14 + | T15 -> + Error `V3_store_from_the_future + in + let generation = generation pl.status in + (* 2. Open the other files *) + let* suffix = + let path = Irmin_pack.Layout.V3.suffix ~root ~generation in + let end_offset = pl.entry_offset_suffix_end in + Suffix.open_ro ~path ~end_offset ~dead_header_size + in + let* prefix = + let path = Irmin_pack.Layout.V3.prefix ~root ~generation in + only_open_after_gc ~path ~generation + in + let* mapping = + let path = Irmin_pack.Layout.V3.mapping ~root ~generation in + only_open_after_gc ~path ~generation + in + let* dict = + let path = Irmin_pack.Layout.V3.dict ~root in + let end_offset = pl.dict_offset_end in + Dict.open_ro ~path ~end_offset ~dead_header_size + in + let* index = + let log_size = Conf.index_log_size config in + let throttle = Conf.merge_throttle config in + Index.v ~fresh:false ~readonly:true ~throttle ~log_size root + in + (* 3. return with success *) + Ok + { + dict; + control; + suffix; + prefix; + mapping; + use_fsync; + indexing_strategy; + index; + mapping_consumers = []; + dict_consumers = []; + suffix_consumers = []; + root; + } + + (* MISC. ****************************************************************** *) + + let version ~root = + let v2_or_v1 () = + let path = Irmin_pack.Layout.V1_and_v2.pack ~root in + match read_version_from_legacy_file path with + | Ok v -> Ok v + | Error `Double_close | Error `Invalid_argument | Error `Closed -> + assert false + | Error `No_such_file_or_directory -> Error `Invalid_layout + | Error `Not_a_file -> Error `Invalid_layout + | Error `Corrupted_legacy_file | Error `Read_out_of_bounds -> + Error `Corrupted_legacy_file + | Error (`Io_misc _) as e -> e + in + match Io.classify_path root with + | `No_such_file_or_directory -> Error `No_such_file_or_directory + | `File | `Other -> Error (`Not_a_directory root) + | `Directory -> ( + let path = Irmin_pack.Layout.V3.control ~root in + match Control.open_ ~path ~readonly:true with + | Ok _ -> Ok `V3 + | Error `No_such_file_or_directory -> v2_or_v1 () + | Error `Not_a_file -> Error `Invalid_layout + | Error `Closed -> assert false + | Error + ( `Io_misc _ | `Corrupted_control_file + | `Unknown_major_pack_version _ ) as e -> + e) + + let swap t ~generation ~right_start_offset ~right_end_offset = + let open Result_syntax in + [%log.debug + "Gc in main: swap %d %#d %#d\n%!" generation + (Int63.to_int right_start_offset) + (Int63.to_int right_end_offset)]; + (* Step 1. Reopen files *) + let* () = reopen_prefix t ~generation in + let* () = reopen_mapping t ~generation in + (* When opening the suffix in append_only we need to provide a (real) suffix + offset, computed from the global ones. *) + let open Int63.Syntax in + let suffix_end_offset = right_end_offset - right_start_offset in + let* () = reopen_suffix t ~generation ~end_offset:suffix_end_offset in + + (* Step 2. Reload mapping consumers (i.e. dispatcher) *) + let* () = + let res = + List.fold_left + (fun acc { after_reload } -> Result.bind acc after_reload) + (Ok ()) t.mapping_consumers + in + (* The following dirty trick casts the result from + [read_error] to [ [>read_error] ]. *) + match res with Ok () -> Ok () | Error (#Errs.t as e) -> Error e + in + + (* Step 3. Update the control file *) + let* () = + let pl = Control.payload t.control in + let pl = + let open Payload in + (* [swap] will logically only be called while in one of the 2 statuses. *) + let status = + match pl.status with + | From_v1_v2_post_upgrade _ -> assert false + | From_v3_used_non_minimal_indexing_strategy -> assert false + | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 + | T14 | T15 -> + assert false + | From_v3_gced _ | From_v3_no_gc_yet -> + let entry_offset_suffix_start = right_start_offset in + From_v3_gced { entry_offset_suffix_start; generation } + in + { pl with status; entry_offset_suffix_end = suffix_end_offset } + in + [%log.debug "GC: writing new control_file"]; + Control.set_payload t.control pl + in + + Ok () + + let write_gc_output ~root ~generation output = + let open Result_syntax in + let path = Irmin_pack.Layout.V3.gc_result ~root ~generation in + let* io = Io.create ~path ~overwrite:true in + let out = Errs.to_json_string output in + let* () = Io.write_string io ~off:Int63.zero out in + Io.close io + + type read_gc_output_error = + [ `Corrupted_gc_result_file of string | `Gc_process_error of string ] + [@@deriving irmin] + + let read_gc_output ~root ~generation = + let open Result_syntax in + let read_file () = + let path = Irmin_pack.Layout.V3.gc_result ~root ~generation in + let* io = Io.open_ ~path ~readonly:true in + let* len = Io.read_size io in + let len = Int63.to_int len in + let* string = Io.read_to_string io ~off:Int63.zero ~len in + let* () = Io.close io in + Ok string + in + match read_file () with + | Error err -> Error (`Corrupted_gc_result_file (Fmt.str "%a" Errs.pp err)) + | Ok x -> + Errs.of_json_string x + |> Result.map_error (fun err -> + `Gc_process_error (Fmt.str "%a" Errs.pp err)) + + let readonly t = Suffix.readonly t.suffix + + let generation t = + let pl = Control.payload t.control in + match pl.status with + | From_v1_v2_post_upgrade _ | From_v3_used_non_minimal_indexing_strategy -> + 0 + | From_v3_no_gc_yet -> 0 + | From_v3_gced x -> x.generation + | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14 + | T15 -> + (* Unreachable *) + assert false + + let gc_allowed t = + let pl = Control.payload t.control in + match pl.status with + | From_v1_v2_post_upgrade _ | From_v3_used_non_minimal_indexing_strategy -> + false + | From_v3_no_gc_yet | From_v3_gced _ -> true + | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9 | T10 | T11 | T12 | T13 | T14 + | T15 -> + (* Unreachable *) + assert false +end diff --git a/vendors/irmin/src/irmin-pack/unix/file_manager.mli b/vendors/irmin/src/irmin-pack/unix/file_manager.mli new file mode 100644 index 0000000000000000000000000000000000000000..e4174c98ccee7deaa169f41f3f25c89618d677a1 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/file_manager.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include File_manager_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/unix/file_manager_intf.ml b/vendors/irmin/src/irmin-pack/unix/file_manager_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..f81aa16c72c114da3b5cd6b2fcc28d33ec5b034f --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/file_manager_intf.ml @@ -0,0 +1,218 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +module type S = sig + (** Abstraction that governs the lifetime of the various files that are part + of a pack store (except the branch store). + + The file manager handles the files one by one and makes explicit all the + interactions between them (except the index which is handled at a high + level). *) + + module Io : Io.S + module Control : Control_file.S with module Io = Io + module Dict : Append_only_file.S with module Io = Io + module Suffix : Append_only_file.S with module Io = Io + module Index : Pack_index.S + module Errs : Io_errors.S with module Io = Io + + type t + + val control : t -> Control.t + val dict : t -> Dict.t + val suffix : t -> Suffix.t + val index : t -> Index.t + val mapping : t -> Io.t option + val prefix : t -> Io.t option + + type create_error := + [ Io.create_error + | Io.write_error + | Io.open_error + | Io.mkdir_error + | `Not_a_directory of string + | `Index_failure of string ] + + val create_rw : + overwrite:bool -> Irmin.Backend.Conf.t -> (t, [> create_error ]) result + (** Note on SWMR consistency: It is undefined for a reader to attempt an + opening before [create_rw] is over. + + Note on crash consistency: Crashing during [create_rw] leaves the storage + in an undefined state. + + Note on errors: If [create_rw] returns an error, the storage is left in an + undefined state and some file descriptors might not be closed. *) + + type open_rw_error := + [ `Corrupted_control_file + | `Double_close + | `Closed + | `File_exists of string + | `Index_failure of string + | `Invalid_argument + | `Invalid_layout + | `Io_misc of Control.Io.misc_error + | `Migration_needed + | `No_such_file_or_directory + | `Not_a_directory of string + | `Not_a_file + | `Read_out_of_bounds + | `Ro_not_allowed + | `Sys_error of string + | `V3_store_from_the_future + | `Only_minimal_indexing_strategy_allowed + | `Unknown_major_pack_version of string + | `Index_failure of string + | `Sys_error of string ] + + val open_rw : Irmin.Backend.Conf.t -> (t, [> open_rw_error ]) result + (** Note on SWMR consistency: It is undefined for a reader to attempt and + opening during an [open_rw]. + + Note on crash consistency: If [open_rw] crashes during + [open_rw_migrate_from_v1_v2], the storage is left in an undefined state. + Otherwise the storage is unaffected. + + Note on errors: If [open_rw] returns an error during + [open_rw_migrate_from_v1_v2], the storage is left in an undefined state. + Otherwise the storage is unaffected. Anyhow, some file descriptors might + not be closed. *) + + type open_ro_error := + [ `Corrupted_control_file + | `File_exists of string + | `Io_misc of Io.misc_error + | `Migration_needed + | `No_such_file_or_directory + | `Not_a_file + | `Closed + | `V3_store_from_the_future + | `Index_failure of string + | `Unknown_major_pack_version of string ] + + val open_ro : Irmin.Backend.Conf.t -> (t, [> open_ro_error ]) result + (** Note on SWMR consistency: TODO: doc + + Note on crash consistency: The storage is never mutated. + + Note on errors: The storage is never mutated. Some file descriptors might + not be closed. *) + + type close_error := + [ `Double_close + | `Index_failure of string + | `Io_misc of Io.misc_error + | `Pending_flush ] + + val close : t -> (unit, [> close_error ]) result + (** Close all the files. + + This call fails if the append buffers are not in a flushed stated. This + situation will most likely never occur because the append buffers will + contain data only during the scope of a batch function. + + After *) + + type flush_error := + [ `Index_failure of string + | `Io_misc of Io.misc_error + | `Ro_not_allowed + | `Closed ] + + type flush_stages := [ `After_dict | `After_suffix ] + type 'a hook := 'a -> unit + + val flush : ?hook:flush_stages hook -> t -> (unit, [> flush_error ]) result + + type reload_stages := [ `After_index | `After_control | `After_suffix ] + + val reload : ?hook:reload_stages hook -> t -> (unit, [> Errs.t ]) result + + val register_mapping_consumer : + t -> after_reload:(unit -> (unit, Errs.t) result) -> unit + + val register_dict_consumer : + t -> after_reload:(unit -> (unit, Errs.t) result) -> unit + + val register_suffix_consumer : t -> after_flush:(unit -> unit) -> unit + + type version_error := + [ `Corrupted_control_file + | `Corrupted_legacy_file + | `Invalid_layout + | `Io_misc of Io.misc_error + | `No_such_file_or_directory + | `Not_a_directory of string + | `Unknown_major_pack_version of string ] + + val version : root:string -> (Import.Version.t, [> version_error ]) result + (** [version ~root] is the version of the files at [root]. *) + + val swap : + t -> + generation:int -> + right_start_offset:int63 -> + right_end_offset:int63 -> + (unit, [> Errs.t ]) result + + type write_gc_output_error := + [ `Double_close + | `File_exists of string + | `Io_misc of Io.misc_error + | `Ro_not_allowed + | `Closed ] + + val write_gc_output : + root:string -> + generation:int -> + (int63, Errs.t) result -> + (unit, [> write_gc_output_error ]) result + (** Used by the gc process at the end to write its output in + store..out. *) + + type read_gc_output_error = + [ `Corrupted_gc_result_file of string | `Gc_process_error of string ] + [@@deriving irmin] + + val read_gc_output : + root:string -> generation:int -> (int63, [> read_gc_output_error ]) result + (** Used by the main process, after the gc process finished, to read + store..out. *) + + val readonly : t -> bool + val generation : t -> int + val gc_allowed : t -> bool +end + +module type Sigs = sig + module type S = S + + module Make + (Control : Control_file.S with module Io = Io.Unix) + (Dict : Append_only_file.S with module Io = Control.Io) + (Suffix : Append_only_file.S with module Io = Control.Io) + (Index : Pack_index.S) + (Errs : Io_errors.S with module Io = Control.Io) : + S + with module Io = Control.Io + and module Control = Control + and module Dict = Dict + and module Suffix = Suffix + and module Index = Index +end diff --git a/vendors/irmin/src/irmin-pack/unix/gc.ml b/vendors/irmin/src/irmin-pack/unix/gc.ml new file mode 100644 index 0000000000000000000000000000000000000000..7089878cc3f1beecc0d6939fdaa92e7c5e541c56 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/gc.ml @@ -0,0 +1,385 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module Payload = Control_file.Latest_payload + +let buffer_size = 8192 + +exception Pack_error = Errors.Pack_error + +module type Args = sig + (* The following [with module Io = Io.Unix] forces unix *) + module Fm : File_manager.S with module Io = Io.Unix + module Dict : Dict.S with module Fm = Fm + module Errs : Io_errors.S with module Io = Fm.Io + module Dispatcher : Dispatcher.S with module Fm = Fm + + type hash + type key = hash Irmin_pack.Pack_key.t [@@deriving irmin] + + module Hash : sig + val hash_size : int + end + + module Node_value : sig + type t + type step + + val pred : + t -> + (step option * [ `Contents of key | `Inode of key | `Node of key ]) list + end + + module Node_store : sig + type 'a t + + val v : + config:Irmin.Backend.Conf.t -> + fm:Fm.t -> + dict:Dict.t -> + dispatcher:Dispatcher.t -> + read t + + val unsafe_find : + check_integrity:bool -> [< read ] t -> key -> Node_value.t option + end + + module Commit_value : sig + type t + + val node : t -> key + val parents : t -> key list + end + + module Commit_store : + Pack_store.S + with type value = Commit_value.t + and type key = key + and type file_manager = Fm.t + and type dict = Dict.t + and type dispatcher = Dispatcher.t + and type hash = hash +end + +module type S = sig + module Args : Args + + val run_and_output_result : generation:int -> string -> Args.key -> int63 + + val transfer_append_exn : + read_exn:(off:int63 -> len:int -> bytes -> unit) -> + append_exn:(string -> unit) -> + off:int63 -> + len:int63 -> + bytes -> + unit +end + +module Make (Args : Args) : S with module Args := Args = struct + open Args + module Io = Fm.Io + module Mapping_file = Mapping_file.Make (Errs) + module Ao = Append_only_file.Make (Io) + + module X = struct + type t = int63 [@@deriving irmin] + + let equal = Irmin.Type.(unstage (equal t)) + let hash = Irmin.Type.(unstage (short_hash t)) + let hash (t : t) : int = hash t + end + + module Table = Hashtbl.Make (X) + + let string_of_key = Irmin.Type.to_string key_t + + let transfer_append_exn ~read_exn ~append_exn ~(off : int63) ~(len : int63) + buffer = + let buffer_size = Bytes.length buffer |> Int63.of_int in + let rec aux off len_remaining = + let open Int63.Syntax in + let min a b = if a < b then a else b in + let len = min buffer_size len_remaining in + let len' = Int63.to_int len in + read_exn ~off ~len:len' buffer; + let () = + if len = buffer_size then append_exn (Bytes.to_string buffer) + else append_exn (String.sub (Bytes.to_string buffer) 0 len') + in + let len_remaining = len_remaining - len in + if len_remaining > Int63.zero then aux (off + len) len_remaining + in + aux off len + + (** [iter_from_node_key node_key _ _ ~f] calls [f] with the key of the node + and iterates over its children. + + [f k] returns [Follow] or [No_follow], indicating the iteration algorithm + if the children of [k] should be traversed or skiped. *) + let iter node_key node_store ~f k = + let marks = Table.create 1024 in + let mark offset = Table.add marks offset () in + let has_mark offset = Table.mem marks offset in + let rec iter_from_node_key_exn node_key node_store ~f k = + match + Node_store.unsafe_find ~check_integrity:false node_store node_key + with + | None -> raise (Pack_error (`Dangling_key (string_of_key node_key))) + | Some node -> + iter_from_node_children_exn node_store ~f (Node_value.pred node) k + and iter_from_node_children_exn node_store ~f children k = + match children with + | [] -> k () + | (_step, kinded_key) :: tl -> ( + let k () = iter_from_node_children_exn node_store ~f tl k in + match kinded_key with + | `Contents key -> + let (_ : int63) = f key in + k () + | `Inode key | `Node key -> + let offset = f key in + if has_mark offset then k () + else ( + mark offset; + iter_from_node_key_exn key node_store ~f k)) + in + iter_from_node_key_exn node_key node_store ~f k + + (* Dangling_parent_commit are the parents of the gced commit. They are kept on + disk in order to correctly deserialised the gced commit. *) + let magic_parent = + Pack_value.Kind.to_magic Pack_value.Kind.Dangling_parent_commit + + (* Transfer the commit with a different magic. Note that this is modifying + existing written data. *) + let transfer_parent_commit_exn ~read_exn ~write_exn ~mapping key = + let off, len = + match Irmin_pack.Pack_key.inspect key with + | Indexed _ -> + (* As this is the second time we are reading this key, this case is + unreachable. *) + assert false + | Direct { offset; length; _ } -> (offset, length) + in + let buffer = Bytes.create len in + read_exn ~off ~len buffer; + let poff = Dispatcher.poff_of_entry_exn ~off ~len mapping in + Bytes.set buffer Hash.hash_size magic_parent; + (* Bytes.unsafe_to_string usage: We assume read_exn returns unique ownership of buffer + to this function. Then at the call to Bytes.unsafe_to_string we give up unique + ownership to buffer (we do not modify it thereafter) in return for ownership of the + resulting string, which we pass to write_exn. This usage is safe. *) + write_exn ~off:poff ~len (Bytes.unsafe_to_string buffer) + + let create_new_suffix ~root ~generation = + let open Result_syntax in + let path = Irmin_pack.Layout.V3.suffix ~root ~generation in + let auto_flush_threshold = 1_000_000 in + let suffix_ref = ref None in + let auto_flush_callback () = + match !suffix_ref with + | None -> assert false + | Some x -> Ao.flush x |> Errs.raise_if_error + in + let* suffix = + Ao.create_rw ~path ~overwrite:true ~auto_flush_threshold + ~auto_flush_callback + in + suffix_ref := Some suffix; + Ok suffix + + let run ~generation root commit_key = + let open Result_syntax in + let config = + Irmin_pack.Conf.init ~fresh:false ~readonly:true ~lru_size:0 root + in + + (* Step 1. Open the files *) + [%log.debug "GC: opening files in RO mode"]; + let* fm = Fm.open_ro config in + Errors.finalise (fun _outcome -> + Fm.close fm |> Errs.log_if_error "GC: Close File_manager") + @@ fun () -> + let* dict = Dict.v fm in + let* dispatcher = Dispatcher.v ~root fm in + let node_store = Node_store.v ~config ~fm ~dict ~dispatcher in + let commit_store = Commit_store.v ~config ~fm ~dict ~dispatcher in + + (* Step 2. Load commit which will make [commit_key] [Direct] if it's not + already the case. *) + let* commit = + match + Commit_store.unsafe_find ~check_integrity:false commit_store commit_key + with + | None -> Error (`Commit_key_is_dangling (string_of_key commit_key)) + | Some commit -> Ok commit + in + let commit_offset, commit_len = + let state : _ Irmin_pack.Pack_key.state = + Irmin_pack.Pack_key.inspect commit_key + in + match state with + | Indexed _ -> assert false + | Direct x -> (x.offset, x.length) + in + + (* Step 3. Create the new mapping. *) + let* () = + (* Step 3.1 Start [Mapping_file] routine which will create the + reachable file. *) + (fun f -> Mapping_file.create ~root ~generation ~register_entries:f) + @@ fun ~register_entry -> + (* Step 3.2 Put the commit parents in the reachable file. + The parent(s) of [commit_key] must be included in the iteration + because, when decoding the [Commit_value.t] at [commit_key], the + parents will have to be read in order to produce a key for them. *) + let register_object_exn key = + match Irmin_pack.Pack_key.inspect key with + | Indexed _ -> + raise + (Pack_error (`Commit_parent_key_is_indexed (string_of_key key))) + | Direct { offset; length; _ } -> register_entry ~off:offset ~len:length + in + List.iter register_object_exn (Commit_value.parents commit); + + (* Step 3.3 Put the nodes and contents in the reachable file. *) + let register_object_exn key = + match Irmin_pack.Pack_key.inspect key with + | Indexed _ -> + raise + (Pack_error (`Node_or_contents_key_is_indexed (string_of_key key))) + | Direct { offset; length; _ } -> + register_entry ~off:offset ~len:length; + offset + in + let node_key = Commit_value.node commit in + let (_ : int63) = register_object_exn node_key in + iter node_key node_store ~f:register_object_exn (fun () -> ()); + + (* Step 3.4 Return and let the [Mapping_file] routine create the mapping + file. *) + () + in + + let path = Irmin_pack.Layout.V3.mapping ~root ~generation in + let* mapping = Io.open_ ~path ~readonly:true in + let* () = + Errors.finalise (fun _ -> + Io.close mapping |> Errs.log_if_error "GC: Close mapping") + @@ fun () -> + (); + + (* Step 4. Create the new prefix. *) + let prefix_ref = ref None in + let auto_flush_callback () = + match !prefix_ref with + | None -> assert false + | Some x -> Ao.flush x |> Errs.raise_if_error + in + let* prefix = + let path = Irmin_pack.Layout.V3.prefix ~root ~generation in + Ao.create_rw ~path ~overwrite:true ~auto_flush_threshold:1_000_000 + ~auto_flush_callback + in + prefix_ref := Some prefix; + let* () = + Errors.finalise (fun _outcome -> + Ao.close prefix |> Errs.log_if_error "GC: Close prefix") + @@ fun () -> + (); + + (* Step 5. Transfer to the new prefix, flush and close. *) + [%log.debug "GC: transfering to the new prefix"]; + let buffer = Bytes.create buffer_size in + (* Step 5.1. Transfer all. *) + let read_exn = Dispatcher.read_in_prefix_and_suffix_exn dispatcher in + let append_exn = Ao.append_exn prefix in + let f ~off ~len = + let len = Int63.of_int len in + transfer_append_exn ~read_exn ~append_exn ~off ~len buffer + in + let* () = Mapping_file.iter mapping f in + Ao.flush prefix + in + (* Step 5.2. Transfer again the parent commits but with a modified + magic. Load the mapping in memory to do a safe localisation of the + parent commits. Reopen the new prefix, this time _not_ in append-only + as we have to modify data inside the file. *) + let* in_memory_map = Dispatcher.load_mapping mapping in + let read_exn = Dispatcher.read_exn dispatcher in + let* prefix = + let path = Irmin_pack.Layout.V3.prefix ~root ~generation in + Io.open_ ~path ~readonly:false + in + let* () = + Errors.finalise (fun _outcome -> + Io.close prefix + |> Errs.log_if_error "GC: Close prefix after parent rewrite") + @@ fun () -> + let write_exn = Io.write_exn prefix in + List.iter + (fun key -> + transfer_parent_commit_exn ~read_exn ~write_exn + ~mapping:in_memory_map key) + (Commit_value.parents commit); + Ok () + in + Ok () + in + + (* Step 6. Create the new suffix and prepare 2 functions for read and write + operations. *) + let buffer = Bytes.create buffer_size in + [%log.debug "GC: creating new suffix"]; + let* suffix = create_new_suffix ~root ~generation in + Errors.finalise (fun _outcome -> + Ao.close suffix |> Errs.log_if_error "GC: Close suffix") + @@ fun () -> + let read_exn = Dispatcher.read_exn dispatcher in + let append_exn = Ao.append_exn suffix in + let transfer_exn = transfer_append_exn ~read_exn ~append_exn buffer in + + (* Step 7. Transfer to the next suffix. *) + [%log.debug "GC: transfering to the new suffix"]; + let* () = Fm.reload fm in + let pl : Payload.t = Fm.Control.payload (Fm.control fm) in + let end_offset = + Dispatcher.offset_of_suffix_off dispatcher pl.entry_offset_suffix_end + in + let right_size = + let open Int63.Syntax in + let x = end_offset - commit_offset in + assert (x >= Int63.of_int commit_len); + x + in + let flush_and_raise () = Ao.flush suffix |> Errs.raise_if_error in + let* () = + Errs.catch (fun () -> + transfer_exn ~off:commit_offset ~len:right_size; + flush_and_raise ()) + in + (* Step 8. Inform the caller of the end_offset copied. *) + Ok end_offset + + (* No one catches errors when this function terminates. Write the result in a + file and terminate the process with an exception, if needed. *) + let run_and_output_result ~generation root commit_key = + let result = run ~generation root commit_key in + let write_result = Fm.write_gc_output ~root ~generation result in + write_result |> Errs.raise_if_error; + result |> Errs.raise_if_error +end diff --git a/vendors/irmin/src/irmin-pack/unix/import.ml b/vendors/irmin/src/irmin-pack/unix/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..b9e1ffdcc8421c423aaba77893c8944aa347e129 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/import.ml @@ -0,0 +1,57 @@ +(* + * Copyright (c)2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends + +let src = Logs.Src.create "irmin-pack.unix" ~doc:"irmin-pack unix backend" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Int63 = struct + include Optint.Int63 + + let t = Irmin.Type.int63 + + module Syntax = struct + let ( + ) = add + let ( - ) = sub + let ( * ) = mul + let ( / ) = div + let ( < ) a b = compare a b < 0 + let ( <= ) a b = compare a b <= 0 + let ( > ) a b = compare a b > 0 + let ( >= ) a b = compare a b >= 0 + let ( = ) = equal + end +end + +type int63 = Int63.t [@@deriving irmin] + +module Pack_value = Irmin_pack.Pack_value +module Version = Irmin_pack.Version + +module type S = Irmin_pack.S + +module Conf = Irmin_pack.Conf +module Layout = Irmin_pack.Layout +module Pack_key = Irmin_pack.Pack_key +module Stats = Stats +module Indexable = Irmin_pack.Indexable + +module Result_syntax = struct + let ( let+ ) res f = Result.map f res + let ( let* ) res f = Result.bind res f +end diff --git a/vendors/irmin/src/irmin-pack/unix/inode.ml b/vendors/irmin/src/irmin-pack/unix/inode.ml new file mode 100644 index 0000000000000000000000000000000000000000..eafffd887e4f17d05e80ac16788efb089c424c09 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/inode.ml @@ -0,0 +1,60 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +include Irmin_pack.Inode +include Inode_intf + +module Make_persistent + (H : Irmin.Hash.S) + (Node : Irmin.Node.Generic_key.S + with type hash = H.t + and type contents_key = H.t Pack_key.t + and type node_key = H.t Pack_key.t) + (Inter : Internal + with type hash = H.t + and type key = H.t Pack_key.t + and type Snapshot.metadata = Node.metadata + and type Val.step = Node.step) + (Pack : Pack_store.S + with type hash = H.t + and type key = H.t Pack_key.t + and type value = Inter.Raw.t) = +struct + module Raw = Inter.Raw + module Pack = Pack + + type file_manager = Pack.file_manager + type dict = Pack.dict + type dispatcher = Pack.dispatcher + + let to_snapshot = Inter.to_snapshot + + module XKey = Pack_key.Make (H) + include Make (H) (XKey) (Node) (Inter) (Pack) + module Snapshot = Inter.Snapshot + + let of_snapshot t ~index v = + let find ~expected_depth:_ k = + let v = Pack.unsafe_find ~check_integrity:true t k in + v + in + Inter.Val.of_snapshot ~index v find + + let v = Pack.v + let integrity_check = Pack.integrity_check + let purge_lru = Pack.purge_lru +end diff --git a/vendors/irmin/src/irmin-pack/unix/inode.mli b/vendors/irmin/src/irmin-pack/unix/inode.mli new file mode 100644 index 0000000000000000000000000000000000000000..e1569840bf14a04fc9be2d5c9411c5f3adc92611 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/inode.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Inode_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/unix/inode_intf.ml b/vendors/irmin/src/irmin-pack/unix/inode_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..e5686f25b456f7c5543f4b0b30b7e2a6c732ae93 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/inode_intf.ml @@ -0,0 +1,90 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +open Irmin_pack.Inode + +module type Persistent = sig + include S + + type file_manager + type dict + type dispatcher + + val v : + config:Irmin.Backend.Conf.t -> + fm:file_manager -> + dict:dict -> + dispatcher:dispatcher -> + read t + + include Irmin_pack.S.Checkable with type 'a t := 'a t and type hash := hash + + (* val reload : 'a t -> unit *) + val integrity_check_inodes : [ `Read ] t -> key -> (unit, string) result Lwt.t + + module Pack : + Pack_store.S + with type file_manager = file_manager + and type dict = dict + and type dispatcher = dispatcher + and type key := hash Pack_key.t + and type hash := hash + and type 'a t = 'a t + + module Raw : + Raw + with type t = Pack.value + and type hash := hash + and type key := hash Pack_key.t + + module Snapshot : + Snapshot with type hash = hash and type metadata = Val.metadata + + val to_snapshot : Raw.t -> Snapshot.inode + val of_snapshot : 'a t -> index:(hash -> key) -> Snapshot.inode -> value + val purge_lru : 'a t -> unit +end + +module type Sigs = sig + module type S = S + module type Persistent = Persistent + + module Make_persistent + (H : Irmin.Hash.S) + (Node : Irmin.Node.Generic_key.S + with type hash = H.t + and type contents_key = H.t Pack_key.t + and type node_key = H.t Pack_key.t) + (Inter : Internal + with type hash = H.t + and type key = H.t Pack_key.t + and type Snapshot.metadata = Node.metadata + and type Val.step = Node.step) + (Pack : Pack_store.S + with type hash = H.t + and type key = H.t Pack_key.t + and type value = Inter.Raw.t) : + Persistent + with type key = H.t Pack_key.t + and type hash = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step + and type file_manager = Pack.file_manager + and type dict = Pack.dict + and type dispatcher = Pack.dispatcher + and type value = Inter.Val.t +end diff --git a/vendors/irmin/src/irmin-pack/unix/io.ml b/vendors/irmin/src/irmin-pack/unix/io.ml new file mode 100644 index 0000000000000000000000000000000000000000..27093d55e7fdfffbe0dd2b145142821cb96b790a --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/io.ml @@ -0,0 +1,344 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Io_intf + +(* File utils, taken from index.unix package *) +module Util = struct + module Syscalls = Index_unix.Syscalls + + let really_write fd fd_offset buffer buffer_offset length = + let rec aux fd_offset buffer_offset length = + let w = Syscalls.pwrite ~fd ~fd_offset ~buffer ~buffer_offset ~length in + if w = 0 || w = length then () + else + (aux [@tailcall]) + Int63.Syntax.(fd_offset + Int63.of_int w) + (buffer_offset + w) (length - w) + in + aux fd_offset buffer_offset length + + let really_read fd fd_offset length buffer = + let rec aux fd_offset buffer_offset length = + let r = Syscalls.pread ~fd ~fd_offset ~buffer ~buffer_offset ~length in + if r = 0 then buffer_offset (* end of file *) + else if r = length then buffer_offset + r + else + (aux [@tailcall]) + Int63.Syntax.(fd_offset + Int63.of_int r) + (buffer_offset + r) (length - r) + in + aux fd_offset 0 length +end + +module type S = S + +module Unix = struct + type misc_error = Unix.error * string * string + + let unix_error_t = + Irmin.Type.(map string (fun _str -> assert false) Unix.error_message) + + let misc_error_t = Irmin.Type.(triple unix_error_t string string) + + type create_error = [ `Io_misc of misc_error | `File_exists of string ] + + type open_error = + [ `Io_misc of misc_error | `No_such_file_or_directory | `Not_a_file ] + + type read_error = + [ `Io_misc of misc_error + | `Read_out_of_bounds + | `Closed + | `Invalid_argument ] + + type write_error = [ `Io_misc of misc_error | `Ro_not_allowed | `Closed ] + type close_error = [ `Io_misc of misc_error | `Double_close ] + + type mkdir_error = + [ `Io_misc of misc_error + | `File_exists of string + | `No_such_file_or_directory + | `Invalid_parent_directory ] + + let raise_misc_error (x, y, z) = raise (Unix.Unix_error (x, y, z)) + + let catch_misc_error f = + try Ok (f ()) + with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)) + + type t = { + fd : Unix.file_descr; + mutable closed : bool; + readonly : bool; + path : string; + } + + let classify_path p = + Unix.( + try + match (stat p).st_kind with + | S_REG -> `File + | S_DIR -> `Directory + | _ -> `Other + with _ -> `No_such_file_or_directory) + + let default_create_perm = 0o644 + let default_open_perm = 0o644 + let default_mkdir_perm = 0o755 + + let create ~path ~overwrite = + try + match Sys.file_exists path with + | false -> + let fd = + Unix.( + openfile path + [ O_CREAT; O_RDWR; O_EXCL; O_CLOEXEC ] + default_create_perm) + in + Ok { fd; closed = false; readonly = false; path } + | true -> ( + match overwrite with + | true -> + (* The file exists, truncate it and use it. An exception will be + triggered if we don't have the permissions *) + let fd = + Unix.( + openfile path + [ O_RDWR; O_CLOEXEC; O_TRUNC ] + default_create_perm) + in + Ok { fd; closed = false; readonly = false; path } + | false -> Error (`File_exists path)) + with + | Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)) + | Sys_error _ -> assert false + + let open_ ~path ~readonly = + match classify_path path with + | `Directory | `Other -> Error `Not_a_file + | `No_such_file_or_directory -> Error `No_such_file_or_directory + | `File -> ( + let mode = Unix.(if readonly then O_RDONLY else O_RDWR) in + try + let fd = Unix.(openfile path [ mode; O_CLOEXEC ] default_open_perm) in + Ok { fd; closed = false; readonly; path } + with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))) + + let close t = + match t.closed with + | true -> Error `Double_close + | false -> ( + t.closed <- true; + (* mark [t] as closed, even if [Unix.close] fails, since it is recommended + to not retry after an error. see: https://man7.org/linux/man-pages/man2/close.2.html *) + try + Unix.close t.fd; + Ok () + with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))) + + let write_exn t ~off ~len s = + if String.length s < len then raise (Errors.Pack_error `Invalid_argument); + match (t.closed, t.readonly) with + | true, _ -> raise Errors.Closed + | _, true -> raise Errors.RO_not_allowed + | _ -> + (* Bytes.unsafe_of_string usage: s has shared ownership; we assume that + Util.really_write does not mutate buf (i.e., only needs shared ownership). This + usage is safe. *) + let buf = Bytes.unsafe_of_string s in + let () = Util.really_write t.fd off buf 0 len in + Index.Stats.add_write len; + () + + let write_string t ~off s = + let len = String.length s in + try Ok (write_exn t ~off ~len s) with + | Errors.Closed -> Error `Closed + | Errors.RO_not_allowed -> Error `Ro_not_allowed + | Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)) + + let fsync t = + match (t.closed, t.readonly) with + | true, _ -> Error `Closed + | _, true -> Error `Ro_not_allowed + | _ -> ( + try + Unix.fsync t.fd; + Ok () + with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))) + + let read_exn t ~off ~len buf = + if len > Bytes.length buf then raise (Errors.Pack_error `Invalid_argument); + match t.closed with + | true -> raise Errors.Closed + | false -> + let nread = Util.really_read t.fd off len buf in + Index.Stats.add_read nread; + if nread <> len then + (* didn't manage to read the desired amount; in this case the interface seems to + require we return `Read_out_of_bounds FIXME check this, because it is unusual + - the normal API allows return of a short string *) + raise (Errors.Pack_error `Read_out_of_bounds) + + let read_to_string t ~off ~len = + let buf = Bytes.create len in + try + read_exn t ~off ~len buf; + (* Bytes.unsafe_to_string usage: buf is local to this function, so uniquely + owned. We assume read_exn returns unique ownership of buf to this function. Then + at the call to Bytes.unsafe_to_string we give up unique ownership of buf for + ownership of the string. This is safe. *) + Ok (Bytes.unsafe_to_string buf) + with + | Errors.Pack_error ((`Invalid_argument | `Read_out_of_bounds) as e) -> + Error e + | Errors.Closed -> Error `Closed + | Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2)) + + let read_size t = + match t.closed with + | true -> Error `Closed + | false -> ( + try Ok Unix.LargeFile.((fstat t.fd).st_size |> Int63.of_int64) + with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))) + + let readonly t = t.readonly + let path t = t.path + let page_size = 4096 + + let move_file ~src ~dst = + try + Sys.rename src dst; + Ok () + with Sys_error msg -> Error (`Sys_error msg) + + let mkdir path = + match (classify_path (Filename.dirname path), classify_path path) with + | `Directory, `No_such_file_or_directory -> ( + try + Unix.mkdir path default_mkdir_perm; + Ok () + with Unix.Unix_error (e, s1, s2) -> Error (`Io_misc (e, s1, s2))) + | `Directory, (`File | `Directory | `Other) -> Error (`File_exists path) + | `No_such_file_or_directory, `No_such_file_or_directory -> + Error `No_such_file_or_directory + | _ -> Error `Invalid_parent_directory + + let unlink path = + try + Sys.remove path; + Ok () + with Sys_error msg -> Error (`Sys_error msg) + + (* Async using fork/waitpid*) + + module Exit = struct + let proc_list = ref [] + let m = Mutex.create () + + let add gc = + Mutex.lock m; + proc_list := gc :: !proc_list; + Mutex.unlock m + + let remove gc = + Mutex.lock m; + proc_list := List.filter (fun gc' -> gc <> gc') !proc_list; + Mutex.unlock m + + let clean_up () = + List.iter + (fun gc -> + try Unix.kill gc 9 + with Unix.Unix_error (e, s1, s2) -> + [%log.warn + "Killing gc process with pid %d failed with error (%s, %s, %s)" gc + (Unix.error_message e) s1 s2]) + !proc_list + end + + (* Register function to be called when process terminates. If there is a gc + process running, make sure to terminate it. *) + let () = at_exit Exit.clean_up + + type status = [ `Running | `Success | `Cancelled | `Failure of string ] + [@@deriving irmin] + + type task = { pid : int; mutable status : status } + + let async f = + Stdlib.flush_all (); + match Lwt_unix.fork () with + | 0 -> + Lwt_main.Exit_hooks.remove_all (); + Lwt_main.abandon_yielded_and_paused (); + f (); + (* Once the gc is finished, the child process kills itself to + avoid calling at_exit functions in upstream code. *) + Unix.kill (Unix.getpid ()) 9; + assert false (* unreachable *) + | pid -> + Exit.add pid; + { pid; status = `Running } + + let status_of_process_status = function + | Lwt_unix.WSIGNALED -7 -> + `Success (* the child is killing itself when it's done *) + | Lwt_unix.WSIGNALED n -> `Failure (Fmt.str "Signaled %d" n) + | Lwt_unix.WEXITED n -> `Failure (Fmt.str "Exited %d" n) + | Lwt_unix.WSTOPPED n -> `Failure (Fmt.str "Stopped %d" n) + + let cancel t = + let () = + match t.status with + | `Running -> + let pid, _ = Unix.waitpid [ Unix.WNOHANG ] t.pid in + (* Do not block if no child has died yet. In this case the waitpid + returns immediately with a pid equal to 0. *) + if pid = 0 then ( + Unix.kill t.pid 9; + Exit.remove t.pid) + | _ -> () + in + t.status <- `Cancelled + + let status t : status = + match t.status with + | `Running -> + let pid, status = Unix.waitpid [ Unix.WNOHANG ] t.pid in + (* Do not block if no child has died yet. In this case the waitpid + returns immediately with a pid equal to 0. *) + if pid = 0 then `Running + else + let s = status_of_process_status status in + Exit.remove pid; + t.status <- s; + s + | s -> s + + let await t = + match t.status with + | `Running -> + let+ pid, status = Lwt_unix.waitpid [] t.pid in + let s = status_of_process_status status in + Exit.remove pid; + t.status <- s; + s + | s -> Lwt.return s +end diff --git a/vendors/irmin/src/irmin-pack/unix/io.mli b/vendors/irmin/src/irmin-pack/unix/io.mli new file mode 100644 index 0000000000000000000000000000000000000000..f6ec8493a227c2df6a5ef402fc09ab574360e6d9 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/io.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Io_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/unix/io_errors.ml b/vendors/irmin/src/irmin-pack/unix/io_errors.ml new file mode 100644 index 0000000000000000000000000000000000000000..e69d416cb872d473c2061146bc73ecf885e5f4fb --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/io_errors.ml @@ -0,0 +1,77 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +open Errors + +(** Error manager for errors and exceptions defined in {!Errors} and + {!Io.S.misc_error} *) +module type S = sig + module Io : Io.S + + type t = [ Base.t | `Io_misc of Io.misc_error ] + + val pp : Format.formatter -> [< t ] -> unit + val raise_error : [< t ] -> 'a + val log_error : string -> [< t ] -> unit + val catch : (unit -> 'a) -> ('a, [> t ]) result + val raise_if_error : ('a, [< t ]) result -> 'a + val log_if_error : string -> (unit, [< t ]) result -> unit + val to_json_string : (int63, [< t ]) result -> string + val of_json_string : string -> (int63, [> t ]) result +end + +module Make (Io : Io.S) : S with module Io = Io = struct + module Io = Io + + type misc_error = Io.misc_error [@@deriving irmin ~pp] + type io_error = [ `Io_misc of misc_error ] [@@deriving irmin] + type t = [ Base.t | io_error ] + + let pp ppf = function + | `Io_misc e -> pp_misc_error ppf e + | #error as e -> Base.pp ppf e + + let raise_error = function + | `Io_misc e -> Io.raise_misc_error e + | #error as e -> Base.raise_error e + + let log_error context e = [%log.err "%s failed: %a" context pp e] + + let catch f = + try Io.catch_misc_error f with _ as ex -> Base.catch (fun () -> raise ex) + + let raise_if_error = function Ok x -> x | Error e -> raise_error e + + let log_if_error context = function + | Ok _ -> () + | Error e -> log_error context e + + let io_err_result = Irmin.Type.(result int63 io_error_t) + + let to_json_string result = + match result with + | Ok _ as v -> v |> Irmin.Type.to_json_string io_err_result + | Error e -> ( + match e with + | `Io_misc _ as e -> Error e |> Irmin.Type.to_json_string io_err_result + | #error as e -> Error e |> Base.to_json_string) + + let of_json_string string = + match Irmin.Type.of_json_string io_err_result string with + | Error (`Msg _) -> Base.of_json_string string + | Ok result -> (result : (_, io_error) result :> (_, [> t ]) result) +end diff --git a/vendors/irmin/src/irmin-pack/unix/io_intf.ml b/vendors/irmin/src/irmin-pack/unix/io_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..fecdb50acf69074fe6b0e69bd2188f4d17a4dd23 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/io_intf.ml @@ -0,0 +1,146 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +module type S = sig + (** Low level IO abstraction. A typical implementation is unix. This + abstraction is meant to be dead simple. Not a lot of documentation is + required. + + It is not resistant to race condictions. There should not be concurrent + modifications of the files. *) + + type t + + (** {1 Errors} *) + + type misc_error [@@deriving irmin] + (** An abstract error type that contains the IO-backend specific errors. (e.g. + [Unix.error]) *) + + type create_error = [ `Io_misc of misc_error | `File_exists of string ] + + type open_error = + [ `Io_misc of misc_error | `No_such_file_or_directory | `Not_a_file ] + + type read_error = + [ `Io_misc of misc_error + | `Read_out_of_bounds + | `Closed + | `Invalid_argument ] + + type write_error = [ `Io_misc of misc_error | `Ro_not_allowed | `Closed ] + type close_error = [ `Io_misc of misc_error | `Double_close ] + + type mkdir_error = + [ `Io_misc of misc_error + | `File_exists of string + | `No_such_file_or_directory + | `Invalid_parent_directory ] + + (** {1 Safe Functions} + + None of the functions in this section raise exceptions. They may however + perform effects that are always continued. + + {2 Life Cycle} *) + + val create : path:string -> overwrite:bool -> (t, [> create_error ]) result + val open_ : path:string -> readonly:bool -> (t, [> open_error ]) result + val close : t -> (unit, [> close_error ]) result + + (** {2 Write Functions} *) + + val write_string : t -> off:int63 -> string -> (unit, [> write_error ]) result + (** [write_string t ~off s] writes [s] at [offset] in [t]. *) + + val fsync : t -> (unit, [> write_error ]) result + (** [fsync t] persists to the file system the effects of previous [create] or + write. *) + + val move_file : + src:string -> dst:string -> (unit, [> `Sys_error of string ]) result + + val mkdir : string -> (unit, [> mkdir_error ]) result + val unlink : string -> (unit, [> `Sys_error of string ]) result + + (** {2 Read Functions} *) + + val read_to_string : + t -> off:int63 -> len:int -> (string, [> read_error ]) result + (** [read_to_string t ~off ~len] are the [len] bytes of [t] at [off]. *) + + val read_size : t -> (int63, [> read_error ]) result + (** [read_size t] is the number of bytes of the file handled by [t]. + + This function is expensive in the unix implementation because it performs + syscalls. *) + + val classify_path : + string -> [> `File | `Directory | `No_such_file_or_directory | `Other ] + + (** {1 MISC.} *) + + val readonly : t -> bool + val path : t -> string + val page_size : int + + (** {1 Unsafe Functions} + + These functions are equivalents to exising safe ones, but using exceptions + instead of the result monad for performances reasons. *) + + val read_exn : t -> off:int63 -> len:int -> bytes -> unit + (** [read_exn t ~off ~len b] reads the [len] bytes of [t] at [off] to [b]. + + Raises [Errors.Pack_error] and [Errors.RO_not_allowed]. + + Also raises backend-specific exceptions (e.g. [Unix.Unix_error] for the + unix backend). *) + + val write_exn : t -> off:int63 -> len:int -> string -> unit + (** [write_exn t ~off ~len b] writes the first [len] bytes pf [b] to [t] at + offset [off]. + + Raises [Errors.Pack_error] and [Errors.RO_not_allowed]. + + Also raises backend-specific exceptions (e.g. [Unix.Unix_error] for the + unix backend). *) + + val raise_misc_error : misc_error -> 'a + + val catch_misc_error : + (unit -> 'a) -> ('a, [> `Io_misc of misc_error ]) result + + (** Simple async/await *) + + type task + + type status = [ `Running | `Success | `Cancelled | `Failure of string ] + [@@deriving irmin] + + val async : (unit -> unit) -> task + val await : task -> status Lwt.t + val status : task -> status + val cancel : task -> unit +end + +module type Sigs = sig + module type S = S + + module Unix : S with type misc_error = Unix.error * string * string +end diff --git a/vendors/irmin/src/irmin-pack/unix/io_legacy.ml b/vendors/irmin/src/irmin-pack/unix/io_legacy.ml new file mode 100644 index 0000000000000000000000000000000000000000..2597edb2209583e1143ac47951b3a08651d2f12e --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/io_legacy.ml @@ -0,0 +1,206 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Io_legacy_intf + +module Unix : S = struct + module Raw = Index_unix.Private.Raw + + type t = { + file : string; + raw : Raw.t; + mutable offset : int63; + mutable flushed : int63; + readonly : bool; + mutable version : Version.t; + buf : Buffer.t; + } + + let name t = t.file + let header_size = (* offset + version *) Int63.of_int 16 + + let unsafe_flush t = + [%log.debug "IO flush %s" t.file]; + let buf = Buffer.contents t.buf in + if buf = "" then () + else + let offset = t.offset in + Buffer.clear t.buf; + Raw.unsafe_write t.raw ~off:t.flushed buf 0 (String.length buf); + Raw.Offset.set t.raw offset; + let open Int63.Syntax in + (* concurrent append might happen so here t.offset might differ + from offset *) + if + not (t.flushed + Int63.of_int (String.length buf) = header_size + offset) + then + Fmt.failwith "reload error: %s flushed=%a offset+header=%a\n%!" t.file + Int63.pp t.flushed Int63.pp (offset + header_size); + t.flushed <- offset + header_size + + let flush t = + if t.readonly then raise Irmin_pack.RO_not_allowed; + unsafe_flush t + + let auto_flush_limit = Int63.of_int 1_000_000 + + let append t buf = + Buffer.add_string t.buf buf; + let len = Int63.of_int (String.length buf) in + let open Int63.Syntax in + t.offset <- t.offset + len; + if t.offset - t.flushed > auto_flush_limit then flush t + + let set t ~off buf = + if t.readonly then raise Irmin_pack.RO_not_allowed; + unsafe_flush t; + let buf_len = String.length buf in + let open Int63.Syntax in + Raw.unsafe_write t.raw ~off:(header_size + off) buf 0 buf_len; + assert ( + let len = Int63.of_int buf_len in + let off = header_size + off + len in + off <= t.flushed) + + exception Invalid_read of string + + let raise_invalid_read fmt = Fmt.kstr (fun s -> raise (Invalid_read s)) fmt + + let read_buffer t ~off ~buf ~len = + let open Int63.Syntax in + let off = header_size + off in + if (not t.readonly) && off > t.flushed then + raise_invalid_read + "Requested read of %d bytes at offset %a, but only flushed to %a" len + Int63.pp off Int63.pp t.flushed; + Raw.unsafe_read t.raw ~off ~len buf + + let read t ~off buf = read_buffer t ~off ~buf ~len:(Bytes.length buf) + let offset t = t.offset + + let force_offset t = + t.offset <- Raw.Offset.get t.raw; + t.offset + + let version t = + [%log.debug + "[%s] version: %a" (Filename.basename t.file) Version.pp t.version]; + t.version + + let set_version t v = + [%log.debug + "[%s] set_version: %a -> %a" (Filename.basename t.file) Version.pp + t.version Version.pp v]; + Raw.Version.set t.raw (Version.to_bin v); + t.version <- v + + let readonly t = t.readonly + + let protect_unix_exn = function + | Unix.Unix_error _ as e -> failwith (Printexc.to_string e) + | e -> raise e + + let ignore_enoent = function + | Unix.Unix_error (Unix.ENOENT, _, _) -> () + | e -> raise e + + let protect f x = try f x with e -> protect_unix_exn e + let safe f x = try f x with e -> ignore_enoent e + + let mkdir dirname = + let rec aux dir k = + if Sys.file_exists dir && Sys.is_directory dir then k () + else ( + if Sys.file_exists dir then safe Unix.unlink dir; + (aux [@tailcall]) (Filename.dirname dir) (fun () -> + protect (Unix.mkdir dir) 0o755; + k ())) + in + aux dirname (fun () -> ()) + + let raw ~flags ~version ~offset file = + let x = Unix.openfile file flags 0o644 in + let raw = Raw.v x in + let header = + { Raw.Header_prefix.version = Version.to_bin version; offset } + in + Raw.Header_prefix.set raw header; + raw + + let v ~version ~fresh ~readonly file = + let get_version () = + match version with + | Some v -> v + | None -> + Fmt.invalid_arg + "Must supply an explicit version when creating a new store ({ file \ + = %s })" + file + in + let v ~offset ~version raw = + { + version; + file; + offset; + raw; + readonly; + buf = Buffer.create (4 * 1024); + flushed = Int63.Syntax.(header_size + offset); + } + in + let mode = Unix.(if readonly then O_RDONLY else O_RDWR) in + mkdir (Filename.dirname file); + match Sys.file_exists file with + | false -> + let version = get_version () in + let raw = + raw + ~flags:[ O_CREAT; mode; O_CLOEXEC ] + ~version ~offset:Int63.zero file + in + v ~offset:Int63.zero ~version raw + | true -> + let x = Unix.openfile file Unix.[ O_EXCL; mode; O_CLOEXEC ] 0o644 in + let raw = Raw.v x in + if fresh then ( + let version = get_version () in + let header = + { + Raw.Header_prefix.version = Version.to_bin version; + offset = Int63.zero; + } + in + Raw.Header_prefix.set raw header; + v ~offset:Int63.zero ~version raw) + else + let actual_version = + let v_string = Raw.Version.get raw in + match Version.of_bin v_string with + | Some v -> v + | None -> Version.invalid_arg v_string + in + (match version with + | Some v when Version.compare actual_version v > 0 -> + raise (Version.Invalid { expected = v; found = actual_version }) + | _ -> ()); + let offset = Raw.Offset.get raw in + v ~offset ~version:actual_version raw + + let close t = Raw.close t.raw + let exists file = Sys.file_exists file + let size { raw; _ } = (Raw.fstat raw).st_size +end diff --git a/vendors/irmin/src/irmin-pack/unix/io_legacy.mli b/vendors/irmin/src/irmin-pack/unix/io_legacy.mli new file mode 100644 index 0000000000000000000000000000000000000000..13251fd978e741117583eecb76c167259f75ca98 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/io_legacy.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Io_legacy_intf.Sigs diff --git a/vendors/irmin/src/irmin-pack/unix/io_legacy_intf.ml b/vendors/irmin/src/irmin-pack/unix/io_legacy_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..098a13f6148d5446f1e28a61018976d98c782aac --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/io_legacy_intf.ml @@ -0,0 +1,48 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + type t + type path := string + + val v : version:Version.t option -> fresh:bool -> readonly:bool -> path -> t + val name : t -> string + val append : t -> string -> unit + val set : t -> off:int63 -> string -> unit + val read : t -> off:int63 -> bytes -> int + val read_buffer : t -> off:int63 -> buf:bytes -> len:int -> int + val offset : t -> int63 + val force_offset : t -> int63 + val readonly : t -> bool + val flush : t -> unit + val close : t -> unit + val exists : string -> bool + val size : t -> int + val mkdir : string -> unit + + (* {2 Versioning} *) + + val version : t -> Version.t + val set_version : t -> Version.t -> unit +end + +module type Sigs = sig + module type S = S + + module Unix : S +end diff --git a/vendors/irmin/src/irmin-pack/unix/irmin_pack_unix.ml b/vendors/irmin/src/irmin-pack/unix/irmin_pack_unix.ml new file mode 100644 index 0000000000000000000000000000000000000000..9efc1203a64e2dce11b68b6580f9a1b7829f73be --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/irmin_pack_unix.ml @@ -0,0 +1,44 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Stats = Stats +module Index = Pack_index +module Inode = Inode +module Pack_store = Pack_store +module Io_legacy = Io_legacy +module Checks = Checks +module Atomic_write = Atomic_write +module Dict = Dict +module Dispatcher = Dispatcher +module Io = Io +module Errors = Errors +module Io_errors = Io_errors +module Control_file = Control_file +module Append_only_file = Append_only_file +module File_manager = File_manager +module Maker = Ext.Maker + +module KV (Config : Irmin_pack.Conf.S) = struct + type endpoint = unit + type hash = Irmin.Schema.default_hash + + include Irmin_pack.Pack_key.Store_spec + module Maker = Maker (Config) + + type metadata = Irmin.Metadata.None.t + + module Make (C : Irmin.Contents.S) = Maker.Make (Irmin.Schema.KV (C)) +end diff --git a/vendors/irmin/src/irmin-pack/unix/mapping_file.ml b/vendors/irmin/src/irmin-pack/unix/mapping_file.ml new file mode 100644 index 0000000000000000000000000000000000000000..7dd51e13b3096839d672c54a54193a80aab78cb1 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/mapping_file.ml @@ -0,0 +1,459 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** An implementation of "external sorting" (sorting on-disk data) and various + other related routines. + + Most of these routines work with mmap-ed data, as a one dimensional array of + integers, where each pair of integers represents a [(key,value)] pair. + + These routines exist to support the implementation of the sparse file. The + documentation in the sparse file should also be read. + + Usage: We start with a file containing [(off,len)] pairs. These describe + which regions of a file contain data that we need when creating a sparse + file. We first sort these by offset, using {!sort}. We then combine adjacent + extents using {!calculate_extents_oc}. For example, a region [(10,10)] and a + region [(20,10)] will be combined into the single extent [(10,20)]. When + combining extents, we also want to allow some flexibility if two regions are + "almost adjacent". For example, a region [(10,10)] and a region [(21,10)] + will be combined into the single extent [(10,21)], even though there is a + single byte at offset 20 that we do not actually need. The parameter + [gap_tolerance] defines how large this gap between regions can be for them + to be combined in this way. The reason for doing this is that we want the + sparse file to have a small map if possible, and we are happy to include + some unneeded data in the sparse data file if this will make the map + smaller. *) + +open! Import + +(* each entry consists of [step] ints; there is the possibility to generalize to + arbitrary step sizes, but the following code always works with (key,value) pairs, ie + step size is 2 *) +let step_2 = 2 + +(* Should be a multiple of 2 *) +let chunk_sz = 1_000_000 / 8 + +(* Set to 0 until we find decide what to do about sequential traversal of pack files *) +let gap_tolerance = 0 + +module BigArr1 = Bigarray.Array1 + +type int_bigarray = (int, Bigarray.int_elt, Bigarray.c_layout) Bigarray.Array1.t + +module Int_mmap : sig + type t = private { + fn : string; + fd : Unix.file_descr; + mutable arr : int_bigarray; + } + + val create : fn:string -> sz:int -> t + + val open_ : fn:string -> sz:int -> t + (** NOTE [open_ ~fn ~sz] can use [sz=-1] to open with size based on the size + of the underlying file *) + + val close : t -> unit +end = struct + type int_bigarray = + (int, Bigarray.int_elt, Bigarray.c_layout) Bigarray.Array1.t + + type t = { fn : string; fd : Unix.file_descr; mutable arr : int_bigarray } + + (* NOTE both following are shared *) + let shared = true + + let create ~fn ~sz = + assert ( + (not (Sys.file_exists fn)) + || + (Printf.printf "File exists: %s\n%!" fn; + false)); + let fd = + Unix.(openfile fn [ O_CREAT; O_RDWR; O_TRUNC; O_EXCL; O_CLOEXEC ] 0o660) + in + let arr = + let open Bigarray in + Unix.map_file fd Int c_layout shared [| sz |] |> array1_of_genarray + in + { fn; fd; arr } + + (* NOTE sz=-1 is recognized by [map_file] as "derive from size of file"; if we want a + different size (eg because we want the file to grow) we can provide it explicitly *) + let open_ ~fn ~sz = + assert (Sys.file_exists fn); + let fd = Unix.(openfile fn [ O_RDWR ] 0o660) in + let arr = + let open Bigarray in + Unix.map_file fd Int c_layout shared [| sz |] |> array1_of_genarray + in + { fn; fd; arr } + + let close t = + Unix.close t.fd; + (* following tries to make the array unreachable, so GC'able; however, no guarantee + that arr actually is unreachable *) + t.arr <- Bigarray.(Array1.create Int c_layout 0); + () +end + +(** Essentially the Y combinator; useful for anonymous recursive functions. The + k argument is the recursive callExample: + + {[ + iter_k (fun ~k n -> if n = 0 then 1 else n * k (n - 1)) + ]} *) +let iter_k f (x : 'a) = + let rec k x = f ~k x in + k x + +(** [sort_chunks ~arr] sorts each chunk in the bigarray [arr]. + + The [arr] should contain [(k,v)] integer pairs stored successively in the + array. The last chunk may have size less than [chunk_sz] - we don't require + the [arr] to be sized as a multiple of [chunk_sz]. + + The implementation reads chunk-sized amounts of ints into memory as a list + of tuples, sorts the list, and writes the list back out. + + [chunk_sz] is the number of ints that are kept in memory, and so the overall + memory usage is something like [8 * chunk_sz] (with some overhead for the + list.. FIXME perhaps an array would be better) *) +let sort_chunks ~(arr : int_bigarray) = + let arr_sz = Bigarray.Array1.dim arr in + 0 + |> iter_k (fun ~k:kont1 off -> + match off > arr_sz with + | true -> () + | false -> + let sz = min chunk_sz (arr_sz - off) in + (* read in as a list; we may prefer to sort an array instead *) + assert (sz mod step_2 = 0); + let xs = + List.init (sz / step_2) (fun i -> + (arr.{off + (2 * i)}, arr.{off + (2 * i) + 1})) + in + (* sort list *) + let xs = List.sort (fun (k, _) (k', _) -> Int.compare k k') xs in + (* write back out *) + let _write_out = + (xs, off) + |> iter_k (fun ~k:kont2 (xs, off) -> + match xs with + | [] -> () + | (k, v) :: rest -> + arr.{off} <- k; + arr.{off + 1} <- v; + kont2 (rest, off + 2)) + in + (* do next chunk *) + kont1 (off + chunk_sz)); + () + +(* [merge_chunks ~src ~dst] takes previously sorted chunks of [(k,v)] data in + [src] and performs an n-way merge into [dst]. *) +let merge_chunks ~(src : int_bigarray) ~(dst : int_bigarray) = + let src_sz, dst_sz = (BigArr1.dim src, BigArr1.dim dst) in + let _initial_checks = + assert (step_2 = 2); + assert (chunk_sz mod step_2 = 0); + assert (dst_sz >= src_sz); + () + in + (* form subarrays of size [chunk_sz] from [src] *) + let xs = + (0, []) + |> iter_k (fun ~k (off, xs) -> + match off < src_sz with + | false -> xs + | true -> + let arr = BigArr1.sub src off (min chunk_sz (src_sz - off)) in + k (off + chunk_sz, arr :: xs)) + in + (* for each subarr, we start at position 0, and successively move through the array + until the end; we keep the tuple (arr.{off}, off, arr) in a priority queue *) + let open struct + type pos_in_arr = { key : int; off : int; arr : int_bigarray } + + (* Q stands for "priority queue" *) + module Q = Binary_heap.Make (struct + type t = pos_in_arr + + let compare x y = compare x.key y.key + end) + end in + let xs = xs |> List.map (fun arr -> { key = arr.{0}; off = 0; arr }) in + (* form priority queue *) + let q = + let q = + Q.create + ~dummy:{ key = 0; off = 0; arr = BigArr1.sub src 0 0 } + (List.length xs) + in + let _ = xs |> List.iter (fun x -> Q.add q x) in + q + in + (* now repeatedly pull the min elt from q, put corresponding entry in dst, advance elt + offset and put elt back in q *) + let dst_off = + 0 + |> iter_k (fun ~k dst_off -> + match Q.is_empty q with + | true -> + (* return so we can check it is what we think it should be *) + dst_off + | false -> ( + let { key; off; arr } = Q.pop_minimum q in + let v = arr.{off + 1} in + dst.{dst_off} <- key; + dst.{dst_off + 1} <- v; + match off + 2 < BigArr1.dim arr with + | true -> + let off = off + 2 in + Q.add q { key = arr.{off}; off; arr }; + k (dst_off + 2) + | false -> + (* finished with this chunk *) + k (dst_off + 2))) + in + assert (dst_off = src_sz); + () + +(** [sort ~src ~dst] sorts the [src] array of [(k,v)] pairs and places the + result in [dst]. [src] and [dst] must be disjoint. [dst] must be large + enough to hold the result. The data is sorted in chunks; [chunk_sz] is the + number of ints that are kept in memory when sorting each chunk. *) + +(** [sort ~src ~dst] sorts the (key,value) integer data in [src] and places it + in [dst] ([src] and [dst] must be disjoint); [chunk_sz] is the number of + integers that are held in memory when sorting each chunk. *) +let sort ~(src : int_bigarray) ~(dst : int_bigarray) = + sort_chunks ~arr:src; + merge_chunks ~src ~dst; + () + +(** [calculate_extents_oc ~src_is_sorted ~src ~dst] uses the sorted reachability + data in [src] and outputs extent data on [dst]. [gap_tolerance] specifies + how much gap between two extents is allowed for them to be combined into a + single extent. *) + +(** [calculate_extents_oc ~src_is_sorted ~src ~dst] takes {b sorted} [(off,len)] + data from [src], combines adjacent extents, and outputs a minimal set of + (sorted) extents to [dst:out_channel]; the return value is the length of the + part of [dst] that was filled. [gap_tolerance] is used to provide some + looseness when combining extents: if the next extent starts within + [gap_tolerance] of the end of the previous extent, then it is combined with + the previous (the data in the gap, which is not originally part of an + extent, will be counted as part of the resulting extent). This can reduce + the number of extents significantly, at a cost of including gaps where the + data is not actually needed. *) +let calculate_extents_oc ~(src_is_sorted : unit) ~(src : int_bigarray) + ~(register_entry : off:int -> len:int -> unit) : unit = + ignore src_is_sorted; + let src_sz = BigArr1.dim src in + let _ = + assert (src_sz >= 2); + assert (src_sz mod step_2 = 0); + () + in + let off, len = (src.{0}, src.{1}) in + let regions_combined = ref 0 in + let dst_off = + (* iterate over entries in src, combining adjacent entries *) + (2, off, len) + |> iter_k (fun ~k (src_off, off, len) -> + match src_off >= src_sz with + | true -> + (* write out "current" extent *) + register_entry ~off ~len; + () + | false -> ( + (* check if we can combine the next region *) + let off', len' = (src.{src_off}, src.{src_off + 1}) in + assert (off <= off'); + match off' <= off + len + gap_tolerance with + | false -> + (* we can't, so write out current extent and move to next *) + register_entry ~off ~len; + k (src_off + 2, off', len') + | true -> + (* we can combine *) + incr regions_combined; + assert (off <= off'); + (* offs are sorted *) + let len = max len (off' + len' - off) in + k (src_off + 2, off, len))) + in + dst_off + +(* Encoding of offset, length. An improvement would be to use varints to encode + both. *) +type pair = int63 * int63 [@@deriving irmin ~encode_bin ~decode_bin] + +module Make (Errs : Io_errors.S with module Io = Io.Unix) = struct + module Ao = Append_only_file.Make (Io.Unix) + + let create ~root ~generation ~register_entries = + let open Result_syntax in + let path0 = Irmin_pack.Layout.V3.reachable ~generation ~root in + let path1 = Irmin_pack.Layout.V3.sorted ~generation ~root in + let path2 = Irmin_pack.Layout.V3.mapping ~generation ~root in + + let* () = + if Sys.word_size <> 64 then Error `Gc_forbidden_on_32bit_platforms + else Ok () + in + + (* Unlink the 3 files and ignore errors (typically no such file) *) + Io.Unix.unlink path0 |> ignore; + Io.Unix.unlink path1 |> ignore; + Io.Unix.unlink path2 |> ignore; + + (* Create [file0] *) + let file0_ref = ref None in + let auto_flush_callback () = + match !file0_ref with + | None -> assert false + | Some x -> Ao.flush x |> Errs.raise_if_error + in + let* file0 = + Ao.create_rw ~path:path0 ~overwrite:true ~auto_flush_threshold:1_000_000 + ~auto_flush_callback + in + file0_ref := Some file0; + + (* Fill and close [file0] *) + let register_entry ~off ~len = + (* Write [off, len] in native-endian encoding because it will be read + with mmap. *) + (* if Int63.to_int off < 500 then + * Fmt.epr "register_entry < 500: %d %d\n%!" (Int63.to_int off) len; *) + let buffer = Bytes.create 16 in + Bytes.set_int64_ne buffer 0 (Int63.to_int64 off); + Bytes.set_int64_ne buffer 8 (Int64.of_int len); + (* Bytes.unsafe_to_string usage: buffer is uniquely owned; we assume + Bytes.set_int64_ne returns unique ownership; we give up ownership of buffer in + conversion to string. This is safe. *) + Ao.append_exn file0 (Bytes.unsafe_to_string buffer) + in + let* () = Errs.catch (fun () -> register_entries ~register_entry) in + let* () = Ao.flush file0 in + let* () = Ao.close file0 in + + (* Reopen [file0] but as an mmap, create [file1] and fill it. *) + let file0 = Int_mmap.open_ ~fn:path0 ~sz:(-1) in + let sz = BigArr1.dim file0.Int_mmap.arr in + let file1 = Int_mmap.create ~fn:path1 ~sz in + let* () = Errs.catch (fun () -> sort ~src:file0.arr ~dst:file1.arr) in + + (* Close and unlink [file0] *) + Int_mmap.close file0; + Io.Unix.unlink path0 |> ignore; + + (* Create [file2] *) + let file2_ref = ref None in + let auto_flush_callback () = + match !file2_ref with + | None -> assert false + | Some x -> Ao.flush x |> Errs.raise_if_error + in + let* file2 = + Ao.create_rw ~path:path2 ~overwrite:true ~auto_flush_threshold:1_000_000 + ~auto_flush_callback + in + file2_ref := Some file2; + + (* Fill and close [file2]. *) + let register_entry ~off ~len = + (* Write [off, len] with repr because it will be read with repr. *) + + (* if off < 500 then *) + (* Fmt.epr "\nregister_entry < 500: %d %d\n%!" off len; *) + (* Fmt.epr "register_entry of middle file: %d %d\n%!" off len; *) + let off = Int63.of_int off in + let len = Int63.of_int len in + encode_bin_pair (off, len) (Ao.append_exn file2) + in + let* () = + Errs.catch (fun () -> + calculate_extents_oc ~src_is_sorted:() ~src:file1.arr ~register_entry) + in + let* () = Ao.flush file2 in + let* () = Ao.close file2 in + + (* Close and unlink [file1] *) + Int_mmap.close file1; + Io.Unix.unlink path1 |> ignore; + + Ok () + + let iter io f = + let buffer = Bytes.create (16 * 1000) in + let buffer_off = ref 0 in + + let open Int63.Syntax in + let open Int63 in + let min a b = if a < b then a else b in + let entry_bytes = of_int 16 in + let max_entries_per_batch = of_int 1000 in + + (* let max_bytes_per_batch = max_entries_per_batch * entry_bytes in *) + let open Result_syntax in + let* byte_count = Io.Unix.read_size io in + let entry_count = byte_count / entry_bytes in + (* Fmt.epr "\nbyte_count:%#d entry_count:%#d\n%!" (to_int byte_count) (to_int entry_count); *) + let* () = + if entry_count * entry_bytes <> byte_count then + Error (`Corrupted_mapping_file "unexpected file size") + else Ok () + in + + let rec load_batch i last_yielded_end_offset = + let entries_left = entry_count - i in + (* Fmt.epr "load_batch i:%#d, entries_left:%#d \n%!" (to_int i) (to_int entries_left); *) + if entries_left = zero then () + else + let entries_in_batch = min entries_left max_entries_per_batch in + let off = i * entry_bytes in + let len = to_int (entries_in_batch * entry_bytes) in + Io.Unix.read_exn io ~off ~len buffer; + buffer_off := 0; + yield_entries i (i + entries_in_batch) last_yielded_end_offset + and yield_entries i end_i last_yielded_end_offset = + if i = end_i then load_batch i last_yielded_end_offset + else + let off, len = + (* Decoding a pair of int can't fail *) + (* Bytes.unsafe_to_string usage: possibly safe TODO justify safety, or convert + to Bytes.to_string *) + decode_bin_pair (Bytes.unsafe_to_string buffer) buffer_off + in + let () = + if off < last_yielded_end_offset then + let msg = + Fmt.str "Found off:%a len:%a but the previous entry ends as at %a" + Int63.pp off Int63.pp len Int63.pp last_yielded_end_offset + in + raise (Errors.Pack_error (`Corrupted_mapping_file msg)) + in + f ~off ~len:(to_int len); + let last_yielded_end_offset = off + len in + yield_entries (succ i) end_i last_yielded_end_offset + in + Errs.catch (fun () -> load_batch zero zero) +end diff --git a/vendors/irmin/src/irmin-pack/unix/mapping_file.mli b/vendors/irmin/src/irmin-pack/unix/mapping_file.mli new file mode 100644 index 0000000000000000000000000000000000000000..e7741940e1416e2af3bb1c4a84bf05d8743a24b0 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/mapping_file.mli @@ -0,0 +1,49 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module Make (Errs : Io_errors.S with module Io = Io.Unix) : sig + val create : + root:string -> + generation:int -> + register_entries:(register_entry:(off:int63 -> len:int -> unit) -> unit) -> + (unit, [> Errs.t ]) result + (** [create] creates inside the directory [root] a mapping file. It never + raises exceptions. + + [register_entries] is a user callback that is responsible for calling + [register_entry] for each live entry. Duplicates allowed, no specfic order + expected. + + Returns an error if the platform is not 64bits. + + Works on both little-endian and big-endian platforms. + + Creates temporary files in [root] that are unlinked before the function + returns. *) + + val iter : + Io.Unix.t -> (off:int63 -> len:int -> unit) -> (unit, [> Errs.t ]) result + (** [iter ~path f] Iterate over the entries of the mapping file at [path]. + + It is guaranteed for the offsets to be iterated in monotonic order. + + It is guaranteed that entries don't overlap. + + The exceptions raised by [f] are caught and returned (as long as they are + known by [Errs]. *) +end diff --git a/vendors/irmin/src/irmin-pack/unix/pack_index.ml b/vendors/irmin/src/irmin-pack/unix/pack_index.ml new file mode 100644 index 0000000000000000000000000000000000000000..bf113efafeb1dba9ff9a26c6a517fb4adc3b2ce4 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/pack_index.ml @@ -0,0 +1,120 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Pack_index_intf + +module Make (K : Irmin.Hash.S) = struct + module Key = struct + type t = K.t + [@@deriving irmin ~short_hash ~equal ~to_bin_string ~decode_bin] + + let hash = short_hash ?seed:None + let hash_size = 30 + let encode = to_bin_string + let encoded_size = K.hash_size + let decode s off = decode_bin s (ref off) + end + + module Val = struct + type t = int63 * int * Pack_value.Kind.t [@@deriving irmin] + + let encoded_size = (64 / 8) + (32 / 8) + 1 + + let encode ((off, len, kind) : t) = + let buf = Bytes.create encoded_size in + Bytes.set_int64_be buf 0 (Int63.to_int64 off); + Bytes.set_int32_be buf 8 (Int32.of_int len); + Bytes.set buf 12 (Pack_value.Kind.to_magic kind); + (* Bytes.unsafe_to_string usage: buf is local, uniquely owned. We assume the various + functions above return unique ownership of buf. Then in the call to + Bytes.unsafe_to_string we give up unique ownership of buf for ownership of the + resulting string. This is safe. *) + Bytes.unsafe_to_string buf + + let decode s pos : t = + (* Bytes.unsafe_of_string usage: s is shared ownership; buf is shared ownership (we + cannot mutate buf) and the lifetime of buf ends on return from this function; we + assume the Bytes.get... functions require only shared ownership. This usage is + safe. *) + let buf = Bytes.unsafe_of_string s in + let off = Bytes.get_int64_be buf pos |> Int63.of_int64 in + let len = Bytes.get_int32_be buf (pos + 8) |> Int32.to_int in + let kind = Bytes.get buf (pos + 12) |> Pack_value.Kind.of_magic_exn in + (off, len, kind) + end + + module Stats = Index.Stats + module I = Index + module Index = Index_unix.Make (Key) (Val) (Index.Cache.Unbounded) + include Index + + let v_exn = + let cache = None in + Index.v ?cache + + let v ?flush_callback ?fresh ?readonly ?throttle ?lru_size ~log_size root = + try + Ok + (v_exn ?flush_callback ?fresh ?readonly ?throttle ?lru_size ~log_size + root) + with + | I.RO_not_allowed -> + (* Happens when [fresh = true = readonly] *) + assert false + | Index_unix.Private.Raw.Not_written -> + (* This is not expected to be raised but let's catch anyway to trigger + a more precise error instead (i.e. the [assert false] below). This + error is expected to be raised when a RO instance attemps an opening + on a non-existing file. *) + assert false + | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) + | Failure msg -> Error (`Index_failure msg) + + let add ?overcommit t k v = replace ?overcommit t k v + let find t k = match find t k with exception Not_found -> None | h -> Some h + let close_exn t = Index.close t + + let close t = + try + close_exn t; + Ok () + with + | I.RO_not_allowed -> assert false + | Index_unix.Private.Raw.Not_written -> assert false + | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) + | Failure msg -> Error (`Index_failure msg) + + let reload t = + try + Index.sync t; + Ok () + with + | I.RO_not_allowed -> assert false + | Index_unix.Private.Raw.Not_written -> assert false + | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) + | Failure msg -> Error (`Index_failure msg) + + let flush t ~with_fsync = + try + Index.flush ~no_callback:() ~with_fsync t; + Ok () + with + | I.RO_not_allowed -> assert false + | Index_unix.Private.Raw.Not_written -> assert false + | Unix.Unix_error (x, y, z) -> Error (`Io_misc (x, y, z)) + | Failure msg -> Error (`Index_failure msg) +end diff --git a/vendors/irmin/src/irmin-pack/unix/pack_index.mli b/vendors/irmin/src/irmin-pack/unix/pack_index.mli new file mode 100644 index 0000000000000000000000000000000000000000..68fad1731cdcd7f527bf0684d1208e967a9c14b6 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/pack_index.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Pack_index_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/unix/pack_index_intf.ml b/vendors/irmin/src/irmin-pack/unix/pack_index_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..2757dfb5487d030497653df0f1aa6220c2827e78 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/pack_index_intf.ml @@ -0,0 +1,71 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + (** An abstraction on top of the index library that exposes an API that better + fits the irmin-pack use case. *) + + type t + type key + type value = int63 * int * Pack_value.Kind.t + + include Index.S with type value := value and type t := t and type key := key + + val v_exn : + ?flush_callback:(unit -> unit) -> + ?fresh:bool -> + ?readonly:bool -> + ?throttle:[ `Block_writes | `Overcommit_memory ] -> + ?lru_size:int -> + log_size:int -> + string -> + t + + type error := [ `Index_failure of string | `Io_misc of Io.Unix.misc_error ] + + val v : + ?flush_callback:(unit -> unit) -> + ?fresh:bool -> + ?readonly:bool -> + ?throttle:[ `Block_writes | `Overcommit_memory ] -> + ?lru_size:int -> + log_size:int -> + string -> + (t, [> error ]) result + + val reload : t -> (unit, [> error ]) result + val close : t -> (unit, [> error ]) result + val close_exn : t -> unit + val flush : t -> with_fsync:bool -> (unit, [> error ]) result + val find : t -> key -> value option + val add : ?overcommit:bool -> t -> key -> value -> unit + val merge : t -> unit + val mem : t -> key -> bool + val iter : (key -> value -> unit) -> t -> unit + val filter : t -> (key * value -> bool) -> unit + val try_merge : t -> unit + + module Stats = Index.Stats + module Key : Index.Key.S with type t = key +end + +module type Sigs = sig + module type S = S + + module Make (K : Irmin.Hash.S) : S with type key = K.t +end diff --git a/vendors/irmin/src/irmin-pack/unix/pack_store.ml b/vendors/irmin/src/irmin-pack/unix/pack_store.ml new file mode 100644 index 0000000000000000000000000000000000000000..96d9e5a29295d03c2b5d9b4a6b3e57018ebe1bee --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/pack_store.ml @@ -0,0 +1,514 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +include Pack_store_intf + +module Varint = struct + type t = int [@@deriving irmin ~decode_bin] + + (** LEB128 stores 7 bits per byte. An OCaml [int] has at most 63 bits. + [63 / 7] equals [9]. *) + let max_encoded_size = 9 +end + +exception Invalid_read of string +exception Corrupted_store of string + +let invalid_read fmt = Fmt.kstr (fun s -> raise (Invalid_read s)) fmt +let corrupted_store fmt = Fmt.kstr (fun s -> raise (Corrupted_store s)) fmt + +module Table (K : Irmin.Hash.S) = Hashtbl.Make (struct + type t = K.t + + let hash = K.short_hash + let equal = Irmin.Type.(unstage (equal K.t)) +end) + +module Make_without_close_checks + (Fm : File_manager.S) + (Dict : Dict.S) + (Dispatcher : Dispatcher.S with module Fm = Fm) + (Hash : Irmin.Hash.S with type t = Fm.Index.key) + (Val : Pack_value.Persistent + with type hash := Hash.t + and type key := Hash.t Pack_key.t) + (Errs : Io_errors.S with module Io = Fm.Io) = +struct + module Tbl = Table (Hash) + module Control = Fm.Control + module Suffix = Fm.Suffix + module Index = Fm.Index + module Key = Pack_key.Make (Hash) + + module Lru = Irmin.Backend.Lru.Make (struct + include Int63 + + let hash = Hashtbl.hash + end) + + type file_manager = Fm.t + type dict = Dict.t + type dispatcher = Dispatcher.t + + type 'a t = { + lru : Val.t Lru.t; + staging : Val.t Tbl.t; + indexing_strategy : Irmin_pack.Indexing_strategy.t; + fm : Fm.t; + dict : Dict.t; + dispatcher : Dispatcher.t; + } + + type hash = Hash.t [@@deriving irmin ~pp ~equal ~decode_bin] + type key = Key.t [@@deriving irmin ~pp] + type value = Val.t [@@deriving irmin ~pp] + + let index_direct_with_kind t hash = + [%log.debug "index %a" pp_hash hash]; + match Index.find (Fm.index t.fm) hash with + | None -> None + | Some (offset, length, kind) -> + let key = Pack_key.v_direct ~hash ~offset ~length in + Some (key, kind) + + let index_direct t hash = + index_direct_with_kind t hash |> Option.map (fun (key, _) -> key) + + let index t hash = Lwt.return (index_direct t hash) + + let v ~config ~fm ~dict ~dispatcher = + let indexing_strategy = Conf.indexing_strategy config in + let lru_size = Conf.lru_size config in + let staging = Tbl.create 127 in + let lru = Lru.create lru_size in + Fm.register_suffix_consumer fm ~after_flush:(fun () -> Tbl.clear staging); + { lru; staging; indexing_strategy; fm; dict; dispatcher } + + type span = { offset : int63; length : int } + (** The type of contiguous ranges of bytes in the pack file. *) + + (** Refer to the index for the position of a pack entry, assuming it is + indexed: *) + let get_entry_span_from_index_exn t hash : span = + match index_direct t hash with + | Some key' -> ( + match Pack_key.inspect key' with + | Direct { offset; length; _ } -> { offset; length } + | Indexed _ -> + (* [index_direct] returns only [Direct] keys. *) + assert false) + | None -> + corrupted_store "Unexpected object %a missing from index" pp_hash hash + + let offset_of_key t k = + match Pack_key.inspect k with + | Direct { offset; _ } -> offset + | Indexed hash -> + let entry_span = get_entry_span_from_index_exn t hash in + (* Cache the offset and length information in the existing key: *) + Pack_key.promote_exn k ~offset:entry_span.offset + ~length:entry_span.length; + entry_span.offset + + module Entry_prefix = struct + type t = { + hash : hash; + kind : Pack_value.Kind.t; + size_of_value_and_length_header : int option; + (** Remaining bytes in the entry after reading the hash and the kind + (i.e. the length of the length header + the value of the length + header), if the entry has a length header (otherwise [None]). + + NOTE: the length stored in the index and in direct pack keys is + the {!total_entry_length} (including the hash and the kind). See + [pack_value.mli] for a description. *) + } + [@@deriving irmin ~pp_dump] + + let min_length = Hash.hash_size + 1 + let max_length = Hash.hash_size + 1 + Varint.max_encoded_size + + let total_entry_length t = + Option.map (fun len -> min_length + len) t.size_of_value_and_length_header + end + + let read_and_decode_entry_prefix ~off dispatcher = + let buf = Bytes.create Entry_prefix.max_length in + let bytes_read = + Dispatcher.read_at_most_exn dispatcher ~off ~len:Entry_prefix.max_length + buf + in + (* We may read fewer then [Entry_prefix.max_length] bytes when reading the + final entry in the pack file (if the data section of the entry is + shorter than [Varint.max_encoded_size]. In this case, an invalid read + may be discovered below when attempting to decode the length header. *) + if bytes_read < Entry_prefix.min_length then + invalid_read + "Attempted to read an entry at offset %a in the pack file, but got \ + only %d bytes" + Int63.pp off bytes_read; + let hash = + (* Bytes.unsafe_to_string usage: buf is created locally, so we have unique + ownership; we assume Dispatcher.read_at_most_exn returns unique ownership; use of + Bytes.unsafe_to_string converts buffer to shared ownership; the rest of the code + seems to require only shared ownership (buffer is read, but not mutated). This is + safe. *) + decode_bin_hash (Bytes.unsafe_to_string buf) (ref 0) + in + let kind = Pack_value.Kind.of_magic_exn (Bytes.get buf Hash.hash_size) in + let size_of_value_and_length_header = + match Val.length_header kind with + | None -> None + | Some `Varint -> + let length_header_start = Entry_prefix.min_length in + (* The bytes starting at [length_header_start] are a + variable-length length field (if they exist / were read + correctly): *) + let pos_ref = ref length_header_start in + (* Bytes.unsafe_to_string usage: buf is shared at this point; we assume + Varint.decode_bin requires only shared ownership. This usage is safe. *) + let length_header = + Varint.decode_bin (Bytes.unsafe_to_string buf) pos_ref + in + let length_header_length = !pos_ref - length_header_start in + Some (length_header_length + length_header) + in + { Entry_prefix.hash; kind; size_of_value_and_length_header } + + let io_read_and_decode_entry_prefix ~off t = + read_and_decode_entry_prefix ~off t.dispatcher + + (* This function assumes magic is written at hash_size + 1 for every + object. *) + let gced buf = + let kind = Pack_value.Kind.of_magic_exn (Bytes.get buf Hash.hash_size) in + kind = Pack_value.Kind.Dangling_parent_commit + + let io_read_and_decode_hash_if_not_gced ~off t = + let len = Hash.hash_size + 1 in + let buf = Bytes.create len in + let found = Dispatcher.read_if_not_gced t.dispatcher ~off ~len buf in + if (not found) || gced buf then None + else + (* Bytes.unsafe_to_string usafe: buf is create in this function, uniquely owned; we + assume Dispatcher.read_if_not_gced returns unique ownership; then call to + Bytes.unsafe_to_string gives up ownerhsip of buf for ownership of resulting + string. This is safe. *) + let hash = decode_bin_hash (Bytes.unsafe_to_string buf) (ref 0) in + Some hash + + let pack_file_contains_key t k = + let key = Pack_key.inspect k in + match key with + | Indexed hash -> Index.mem (Fm.index t.fm) hash + | Direct { offset; _ } -> ( + let io_offset = Dispatcher.end_offset t.dispatcher in + let minimal_entry_length = Entry_prefix.min_length in + let open Int63.Syntax in + if offset + Int63.of_int minimal_entry_length > io_offset then ( + (* Can't fit an entry into this suffix of the store, so this key + isn't (yet) valid. If we're a read-only instance, the key may + become valid on [reload]; otherwise we know that this key wasn't + constructed for this store. *) + if not (Control.readonly (Fm.control t.fm)) then + invalid_read + "invalid key %a checked for membership (IO offset = %a)" pp_key k + Int63.pp io_offset; + false) + else + (* Read the hash explicitly as an integrity check: *) + match io_read_and_decode_hash_if_not_gced ~off:offset t with + | None -> false + | Some hash -> + let expected_hash = Key.to_hash k in + if not (equal_hash hash expected_hash) then + invalid_read + "invalid key %a checked for membership (read hash %a at this \ + offset instead)" + pp_key k pp_hash hash; + (* At this point we consider the key to be contained in the pack + file. However, we could also be in the presence of a forged (or + unlucky) key that points to an offset that mimics a real pack + entry (e.g. in the middle of a blob). *) + true) + + let unsafe_mem t k = + [%log.debug "[pack] mem %a" pp_key k]; + Tbl.mem t.staging (Key.to_hash k) + || Lru.mem t.lru (offset_of_key t k) + || pack_file_contains_key t k + + let mem t k = + let b = unsafe_mem t k in + Lwt.return b + + let check_hash h v = + let h' = Val.hash v in + if equal_hash h h' then Ok () else Error (h, h') + + let check_key k v = check_hash (Key.to_hash k) v + + let io_read_and_decode_if_not_gced ~off ~len t = + let () = + if not (Fm.readonly t.fm) then + let io_offset = Dispatcher.end_offset t.dispatcher in + let open Int63.Syntax in + if off + Int63.of_int len > io_offset then + (* This is likely a store corruption. We raise [Invalid_read] + specifically so that [integrity_check] below can handle it. *) + invalid_read + "Got request to read %d bytes (at offset %a), but max IO offset is \ + %a" + len Int63.pp off Int63.pp io_offset + in + let buf = Bytes.create len in + let found = Dispatcher.read_if_not_gced t.dispatcher ~off ~len buf in + if (not found) || gced buf then None + else + let key_of_offset offset = + [%log.debug "key_of_offset: %a" Int63.pp offset]; + (* Attempt to eagerly read the length at the same time as reading the + hash in order to save an extra IO read when dereferencing the key: *) + let entry_prefix = io_read_and_decode_entry_prefix ~off:offset t in + (* This function is called on the parents of a commit when deserialising + it. Dangling_parent_commit are usually treated as removed objects, + except here, where in order to correctly deserialise the gced commit, + they are treated as kept commits. *) + let kind = + if entry_prefix.kind = Pack_value.Kind.Dangling_parent_commit then + Pack_value.Kind.Commit_v2 + else entry_prefix.kind + in + let entry_prefix = { entry_prefix with kind } in + match Entry_prefix.total_entry_length entry_prefix with + | Some length -> + Pack_key.v_direct ~hash:entry_prefix.hash ~offset ~length + | None -> + (* NOTE: we could store [offset] in this key, but since we know the + entry doesn't have a length header we'll need to check the index + when dereferencing this key anyway. {i Not} storing the offset + avoids doing another failed check in the pack file for the length + header during [find]. *) + Pack_key.v_indexed entry_prefix.hash + in + let key_of_hash = Pack_key.v_indexed in + let dict = Dict.find t.dict in + let v = + (* Bytes.unsafe_to_string usage: buf created, uniquely owned; after creation, we + assume Dispatcher.read_if_not_gced returns unique ownership; we give up unique + ownership in call to Bytes.unsafe_to_string. This is safe. *) + Val.decode_bin ~key_of_offset ~key_of_hash ~dict + (Bytes.unsafe_to_string buf) + (ref 0) + in + Some v + + let find_in_pack_file ~check_integrity t key = + let loc, { offset; length } = + match Pack_key.inspect key with + | Direct { offset; length; _ } -> + (Stats.Pack_store.Pack_direct, { offset; length }) + | Indexed hash -> + let entry_span = get_entry_span_from_index_exn t hash in + (* Cache the offset and length information in the existing key: *) + Pack_key.promote_exn key ~offset:entry_span.offset + ~length:entry_span.length; + (Stats.Pack_store.Pack_indexed, entry_span) + in + let io_offset = Dispatcher.end_offset t.dispatcher in + let open Int63.Syntax in + if offset + Int63.of_int length > io_offset then ( + (* Can't fit an entry into this suffix of the store, so this key + isn't (yet) valid. If we're a read-only instance, the key may + become valid on [reload]; otherwise we know that this key wasn't + constructed for this store. *) + match Control.readonly (Fm.control t.fm) with + | false -> + invalid_read "attempt to dereference invalid key %a (IO offset = %a)" + pp_key key Int63.pp io_offset + | true -> + [%log.debug + "Direct store key references an unknown starting offset %a (length \ + = %d, IO offset = %a)" + Int63.pp offset length Int63.pp io_offset]; + (Stats.Pack_store.Not_found, None)) + else + match io_read_and_decode_if_not_gced ~off:offset ~len:length t with + | Some v -> + Lru.add t.lru offset v; + (if check_integrity then + check_key key v |> function + | Ok () -> () + | Error (expected, got) -> + corrupted_store "Got hash %a, expecting %a (for val: %a)." + pp_hash got pp_hash expected pp_value v); + (loc, Some v) + | None -> (* TODO: add a new counter in stats*) (loc, None) + + let unsafe_find ~check_integrity t k = + [%log.debug "[pack] find %a" pp_key k]; + let hash = Key.to_hash k in + let off = offset_of_key t k in + let location, value = + match Tbl.find t.staging hash with + | v -> + Lru.add t.lru off v; + (Stats.Pack_store.Staging, Some v) + | exception Not_found -> ( + match Lru.find t.lru off with + | v -> (Stats.Pack_store.Lru, Some v) + | exception Not_found -> find_in_pack_file ~check_integrity t k) + in + Stats.report_pack_store ~field:location; + value + + let find t k = + let v = unsafe_find ~check_integrity:true t k in + Lwt.return v + + let integrity_check ~offset ~length hash t = + try + match io_read_and_decode_if_not_gced ~off:offset ~len:length t with + | None -> Error `Wrong_hash (*TODO: new error for reading gced objects.*) + | Some value -> ( + match check_hash hash value with + | Ok () -> Ok () + | Error _ -> Error `Wrong_hash) + with Invalid_read _ -> Error `Absent_value + + let cast t = (t :> read_write t) + + (** [batch] is required by the [Backend] signature of irmin core, but + irmin-pack is really meant to be used using the [batch] of the repo (in + [ext.ml]). The following batch exists only for compatibility, but it is + very tempting to replace the implementation by an [assert false]. *) + let batch t f = + [%log.warn + "[pack] calling batch directory on a store is not recommended. Use \ + repo.batch instead."]; + let on_success res = + Fm.flush t.fm |> Errs.raise_if_error; + Lwt.return res + in + let on_fail exn = + [%log.info + "[pack] batch failed. calling flush. (%s)" (Printexc.to_string exn)]; + let () = + match Fm.flush t.fm with + | Ok () -> () + | Error err -> + [%log.err + "[pack] batch failed and flush failed. Silencing flush fail. (%a)" + Errs.pp err] + in + raise exn + in + Lwt.try_bind (fun () -> f (cast t)) on_success on_fail + + let unsafe_append ~ensure_unique ~overcommit t hash v = + let unguarded_append () = + [%log.debug "[pack] append %a" pp_hash hash]; + let offset_of_key k = + match Pack_key.inspect k with + | Direct { offset; _ } -> + Stats.incr_appended_offsets (); + Some offset + | Indexed hash -> ( + (* TODO: Why don't we promote the key here? *) + match Index.find (Fm.index t.fm) hash with + | None -> + Stats.incr_appended_hashes (); + None + | Some (offset, _, _) -> + Stats.incr_appended_offsets (); + Some offset) + in + let dict = Dict.index t.dict in + let off = Dispatcher.end_offset t.dispatcher in + + (* [encode_bin] will most likely call [append] several time. One of these + call may trigger an auto flush. *) + let append = Suffix.append_exn (Fm.suffix t.fm) in + Val.encode_bin ~offset_of_key ~dict hash v append; + + let open Int63.Syntax in + let len = Int63.to_int (Dispatcher.end_offset t.dispatcher - off) in + let key = Pack_key.v_direct ~hash ~offset:off ~length:len in + let () = + let kind = Val.kind v in + let should_index = t.indexing_strategy ~value_length:len kind in + if should_index then + Index.add ~overcommit (Fm.index t.fm) hash (off, len, kind) + in + Tbl.add t.staging hash v; + Lru.add t.lru off v; + [%log.debug "[pack] append done %a <- %a" pp_hash hash pp_key key]; + key + in + match ensure_unique with + | false -> unguarded_append () + | true -> ( + match index_direct t hash with + | None -> unguarded_append () + | Some key -> key) + + let unsafe_add t hash v = + unsafe_append ~ensure_unique:true ~overcommit:false t hash v |> Lwt.return + + let add t v = unsafe_add t (Val.hash v) v + + (** This close is a noop. + + Closing the file manager would be inadequate because it is passed to [v]. + The caller should close the file manager. + + We could clear the caches here but that really is not necessary. *) + let close _ = Lwt.return () + + let purge_lru t = Lru.clear t.lru +end + +module Make + (Fm : File_manager.S) + (Dict : Dict.S) + (Dispatcher : Dispatcher.S with module Fm = Fm) + (Hash : Irmin.Hash.S with type t = Fm.Index.key) + (Val : Pack_value.Persistent + with type hash := Hash.t + and type key := Hash.t Pack_key.t) + (Errs : Io_errors.S with module Io = Fm.Io) = +struct + module Inner = + Make_without_close_checks (Fm) (Dict) (Dispatcher) (Hash) (Val) (Errs) + + include Inner + include Indexable.Closeable (Inner) + + let v ~config ~fm ~dict ~dispatcher = + Inner.v ~config ~fm ~dict ~dispatcher |> make_closeable + + let cast t = Inner.cast (get_open_exn t) |> make_closeable + + let integrity_check ~offset ~length k t = + Inner.integrity_check ~offset ~length k (get_open_exn t) + + module Entry_prefix = Inner.Entry_prefix + + let read_and_decode_entry_prefix = Inner.read_and_decode_entry_prefix + let index_direct_with_kind t = Inner.index_direct_with_kind (get_open_exn t) + let purge_lru t = Inner.purge_lru (get_open_exn t) +end diff --git a/vendors/irmin/src/irmin-pack/unix/pack_store.mli b/vendors/irmin/src/irmin-pack/unix/pack_store.mli new file mode 100644 index 0000000000000000000000000000000000000000..01c030a648f8e38bbaa4ef977fb8fec0be4a7755 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/pack_store.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Pack_store_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/unix/pack_store_intf.ml b/vendors/irmin/src/irmin-pack/unix/pack_store_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..664546af73f343dbc8b2a7e51ae22719c7c1da03 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/pack_store_intf.ml @@ -0,0 +1,89 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +(** A [Pack_store.S] is a closeable, persistent implementation of {!Indexable.S} + that uses an append-only file of variable-length data blocks. + + Certain values in the data file are indexed by hash via a {!Pack_index.S} + implementation, but not all of them need be. *) +module type S = sig + include Irmin_pack.Indexable.S + + type file_manager + type dict + type dispatcher + + val v : + config:Irmin.Backend.Conf.t -> + fm:file_manager -> + dict:dict -> + dispatcher:dispatcher -> + read t + + val cast : read t -> read_write t + + (** @inline *) + include Irmin_pack.S.Checkable with type 'a t := 'a t and type hash := hash + + module Entry_prefix : sig + type t = { + hash : hash; + kind : Pack_value.Kind.t; + size_of_value_and_length_header : int option; + (** Remaining bytes in the entry after reading the hash and the kind + (i.e. the length of the length header + the value of the length + header), if the entry has a length header (otherwise [None]). + + NOTE: the length stored in the index and in direct pack keys is + the {!total_entry_length} (including the hash and the kind). *) + } + + val total_entry_length : t -> int option + end + + val read_and_decode_entry_prefix : off:int63 -> dispatcher -> Entry_prefix.t + (** Read the entry prefix at offset [off]. *) + + val index_direct_with_kind : 'a t -> hash -> (key * Pack_value.Kind.t) option + (** Returns the key and the kind of an object indexed by hash. *) + + val purge_lru : 'a t -> unit +end + +module type Sigs = sig + exception Invalid_read of string + + module type S = S + + module Make + (Fm : File_manager.S) + (Dict : Dict.S with module Fm = Fm) + (Dispatcher : Dispatcher.S with module Fm = Fm) + (Hash : Irmin.Hash.S with type t = Fm.Index.key) + (Val : Pack_value.Persistent + with type hash := Hash.t + and type key := Hash.t Pack_key.t) + (Errs : Io_errors.S with module Io = Fm.Io) : + S + with type key = Hash.t Pack_key.t + and type hash = Hash.t + and type value = Val.t + and type file_manager = Fm.t + and type dispatcher = Dispatcher.t + and type dict = Dict.t +end diff --git a/vendors/irmin/src/irmin-pack/unix/snapshot.ml b/vendors/irmin/src/irmin-pack/unix/snapshot.ml new file mode 100644 index 0000000000000000000000000000000000000000..c9e3e880ea58a65890aeb2560f4acb85e3d73304 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/snapshot.ml @@ -0,0 +1,347 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Snapshot_intf + +let rm_index path = + let path_index = Filename.concat path "index" in + Sys.readdir path_index + |> Array.iter (fun name -> Unix.unlink (Filename.concat path_index name)); + Unix.rmdir path_index; + Unix.rmdir path + +module Make (Args : Args) = struct + module Hashes = Irmin.Hash.Set.Make (Args.Hash) + open Args + module Inode_pack = Inode.Pack + module Pack_index = Pack_index.Make (Hash) + + let pp_hash = Irmin.Type.pp Hash.t + let pp_key = Irmin.Type.pp Inode_pack.Key.t + let pp_kind = Irmin.Type.pp Pack_value.Kind.t + let pp_snapshot = Irmin.Type.pp Inode.Snapshot.inode_t + + module Export = struct + module Value_unit = struct + type t = unit [@@deriving irmin] + + let encode _ = "" + let encoded_size = 0 + let decode _ _ = () + end + + module Index = + Index_unix.Make (Pack_index.Key) (Value_unit) (Index.Cache.Unbounded) + + type t = { + fm : Fm.t; + dispatcher : Dispatcher.t; + log_size : int; + inode_pack : read Inode_pack.t; + contents_pack : read Contents_pack.t; + } + + let v config contents_pack inode_pack = + (* In order to read from the pack files, we need to open at least two + files: suffix and control. We just open the file manager for + simplicity. *) + let fm = Fm.open_ro config |> Fm.Errs.raise_if_error in + let dispatcher = + let root = Conf.root config in + Dispatcher.v ~root fm |> Fm.Errs.raise_if_error + in + let log_size = Conf.index_log_size config in + { fm; dispatcher; log_size; inode_pack; contents_pack } + + let close t = Fm.close t.fm + + let key_of_hash hash t = + Inode_pack.index_direct_with_kind t hash |> Option.get + + let length_of_hash hash t = + let key, _ = key_of_hash hash t in + match Pack_key.inspect key with + | Indexed _ -> + (* This case cannot happen, as [key_of_hash] converts an + indexed key to a direct one. *) + assert false + | Direct { length; _ } -> length + + let io_read_and_decode_entry_prefix ~off t = + let entry_prefix : Inode_pack.Entry_prefix.t = + Inode_pack.read_and_decode_entry_prefix ~off t.dispatcher + in + let length = + match Inode_pack.Entry_prefix.total_entry_length entry_prefix with + | Some length -> length + | None -> + (* If the length is not on disk, the object is in index. *) + length_of_hash entry_prefix.hash t.inode_pack + in + let key = Pack_key.v_direct ~hash:entry_prefix.hash ~offset:off ~length in + (key, entry_prefix.kind) + + (* Get the childrens offsets and then read their keys at that offset. *) + let decode_children_offsets ~off ~len t = + let buf = Bytes.create len in + Dispatcher.read_exn t.dispatcher ~off ~len buf; + let entry_of_offset offset = + [%log.debug "key_of_offset: %a" Int63.pp offset]; + io_read_and_decode_entry_prefix ~off:offset t + in + let entry_of_hash hash = key_of_hash hash t.inode_pack in + (* Bytes.unsafe_to_string usage: buf is created locally, uniquely owned; we assume + Dispatcher.read_exn returns unique ownership; then call to Bytes.unsafe_to_string + gives up unique ownership of buf. This is safe. *) + Inode.Raw.decode_children_offsets ~entry_of_offset ~entry_of_hash + (Bytes.unsafe_to_string buf) (* safe: see comment above *) + (ref 0) + + type visit = { visited : Hash.t -> bool; set_visit : Hash.t -> unit } + + let iter t v f_contents f_inodes (root_key, root_kind) = + let total_visited = ref 0 in + let set_visit h = + incr total_visited; + v.set_visit h + in + let rec aux (key, kind) = + match Pack_key.inspect key with + | Indexed _ -> + (* This case cannot happen: + - either the root key is indexed, in which case it converted to a + direct key just before the call to [aux]; + - or one of the children of a node is indexed, in which case + [Inode.Raw.decode_children_offsets] converts it to a direct key + before the call to [aux]. *) + assert false + | Direct { length; offset; hash } -> + if v.visited hash then Lwt.return_unit + else ( + set_visit hash; + [%log.debug "visit hash: %a, %a" pp_hash hash pp_kind kind]; + (* [unsafe_find] decodes the values based on their kind, we need + to detect the type in order to call the correspoding + [unsafe_find].*) + match kind with + | Contents -> ( + let value = + Contents_pack.unsafe_find ~check_integrity:false + t.contents_pack key + in + match value with + | None -> + Fmt.failwith "contents not found in store. Key: %a " + pp_key key + | Some value -> + let snapshot_blob = value in + f_contents snapshot_blob) + | Inode_v1_unstable | Inode_v1_stable | Inode_v2_root + | Inode_v2_nonroot -> ( + let children = + decode_children_offsets ~off:offset ~len:length t + in + let* () = Lwt_list.iter_s (fun key -> aux key) children in + let value = + Inode_pack.unsafe_find ~check_integrity:false t.inode_pack + key + in + match value with + | None -> + Fmt.failwith "node not found in store. Key: %a " pp_key + key + | Some value -> + let snapshot_inode = Inode.to_snapshot value in + [%log.debug + "iter inode snapshot: %a" pp_snapshot snapshot_inode]; + f_inodes snapshot_inode) + | Commit_v1 | Commit_v2 -> + (* The traversal starts with a node, it never iters over + commits. *) + assert false + | Dangling_parent_commit -> assert false) + in + (* In case the root node of a tree is indexed, we need to convert it to a + direct key first. *) + let root_key = + match Pack_key.inspect root_key with + | Indexed hash -> key_of_hash hash t.inode_pack |> fst + | Direct _ -> root_key + in + let* () = aux (root_key, root_kind) in + Lwt.return !total_visited + + let run_in_memory t f_contents f_inodes root_key = + [%log.info "iter in memory"]; + let visited_hash = Hashes.create ~initial_slots:100_000 () in + let visited h = Hashes.mem visited_hash h in + let set_visit h = + match Hashes.add visited_hash h with + | `Duplicate -> + Fmt.failwith "should not visit hash twice. Hash: %a " pp_hash h + | `Ok -> () + in + iter t { visited; set_visit } f_contents f_inodes root_key + + let run_on_disk path t f_contents f_inodes root_key = + [%log.info "iter on disk"]; + let index = + Index.v ~fresh:true ~readonly:false ~log_size:t.log_size path + in + let visited h = Index.mem index h in + let set_visit h = + if visited h then + Fmt.failwith "Should not visit hash twice. Hash: %a " pp_hash h + else Index.replace index h () + in + let* total = iter t { visited; set_visit } f_contents f_inodes root_key in + Index.close index; + rm_index path; + Lwt.return total + + let run ?on_disk = + match on_disk with + | None -> run_in_memory + | Some (`Path path) -> run_on_disk path + end + + module Import = struct + module Value = struct + type t = int63 * int [@@deriving irmin] + + let encoded_size = (64 / 8) + (32 / 8) + + let encode ((off, len) : t) = + let buf = Bytes.create encoded_size in + Bytes.set_int64_be buf 0 (Int63.to_int64 off); + Bytes.set_int32_be buf 8 (Int32.of_int len); + (* Bytes.unsafe_to_string usage: buf is local, uniquely owned; we assume the + Bytes.set... functions return unique ownership; then Bytes.unsafe_to_string + gives up unique ownership of buf to get shared ownership of the resulting + string, which is then returned. buf is no longer accessible. This is safe. *) + Bytes.unsafe_to_string buf + + let decode s pos : t = + (* Bytes.unsafe_of_string usage: s is shared; buf is shared (we cannot mutate it); + we assume Bytes.get_... functions need shared ownership only. This usage is + safe. *) + let buf = Bytes.unsafe_of_string s in + let off = Bytes.get_int64_be buf pos |> Int63.of_int64 in + let len = Bytes.get_int32_be buf (pos + 8) |> Int32.to_int in + (off, len) + end + + module Index = + Index_unix.Make (Pack_index.Key) (Value) (Index.Cache.Unbounded) + + type path = string + + type t = { + inode_pack : read Inode_pack.t; + contents_pack : read Contents_pack.t; + visited : Hash.t -> Hash.t Pack_key.t; + set_visit : Hash.t -> Hash.t Pack_key.t -> unit; + index : (path * Index.t) option; + } + + let save_contents t b : Hash.t Pack_key.t Lwt.t = + let* key = + Contents_pack.batch t.contents_pack (fun writer -> + Contents_pack.add writer b) + in + let hash = Inode.Key.to_hash key in + t.set_visit hash key; + Lwt.return key + + let save_inodes t i : Hash.t Pack_key.t Lwt.t = + let inode = Inode.of_snapshot t.inode_pack ~index:t.visited i in + let key = Inode.save ~allow_non_root:true t.inode_pack inode in + let hash = Inode.Key.to_hash key in + t.set_visit hash key; + Lwt.return key + + let hash_not_found h = + Fmt.failwith + "You are trying to save to the backend an inode that contains pointers \ + to objects unknown to the backend. Hash: %a" + pp_hash h + + let save_reuse_index inodes = + [%log.info "save reuse index "]; + (* objects are added to index by [save_contents] and [save_inodes] + functions. *) + let set_visit _ _ = () in + let visited h = + match Inode_pack.index_direct inodes h with + | Some x -> x + | None -> hash_not_found h + in + (set_visit, visited, None) + + let save_in_memory () = + [%log.info "save in memory"]; + let tbl : (Hash.t, Hash.t Pack_key.t) Hashtbl.t = Hashtbl.create 10 in + let set_visit h k = Hashtbl.add tbl h k in + let visited h = + match Hashtbl.find_opt tbl h with + | Some x -> x + | None -> hash_not_found h + in + (set_visit, visited, None) + + let save_on_disk log_size path = + (* Make sure we are not reusing the same index as irmin-pack. *) + let path = path ^ "_tmp" in + [%log.info "save on disk: %s" path]; + let index = Index.v ~fresh:true ~readonly:false ~log_size path in + + let set_visit h k = + let offset, length = + match Pack_key.inspect k with + | Direct { offset; length; _ } -> (offset, length) + | Indexed _ -> + (* Visited objects have direct keys. *) + assert false + in + Index.replace index h (offset, length) + in + let visited h = + try + let offset, length = Index.find index h in + let key = Pack_key.v_direct ~hash:h ~offset ~length in + key + with Not_found -> hash_not_found h + in + (set_visit, visited, Some (path, index)) + + let v ?on_disk log_size contents_pack inode_pack = + let set_visit, visited, index = + match on_disk with + | None -> save_in_memory () + | Some (`Path path) -> save_on_disk log_size path + | Some `Reuse -> save_reuse_index inode_pack + in + { inode_pack; contents_pack; visited; set_visit; index } + + let close t = + Option.iter + (fun (path, index) -> + Index.close index; + rm_index path) + t.index + end +end diff --git a/vendors/irmin/src/irmin-pack/unix/snapshot.mli b/vendors/irmin/src/irmin-pack/unix/snapshot.mli new file mode 100644 index 0000000000000000000000000000000000000000..a096ffbd1d5b6e29109822ee754fca6af2c10ae9 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/snapshot.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Snapshot_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin-pack/unix/snapshot_intf.ml b/vendors/irmin/src/irmin-pack/unix/snapshot_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..5ec8e66e1c45d035512f8494030a543b4573965a --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/snapshot_intf.ml @@ -0,0 +1,80 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type Args = sig + module Hash : Irmin.Hash.S + module Fm : File_manager.S + module Dispatcher : Dispatcher.S with module Fm = Fm + + module Inode : + Inode.Persistent + with type hash := Hash.t + and type key = Hash.t Pack_key.t + and type file_manager = Fm.t + and type dispatcher = Dispatcher.t + + module Contents_pack : + Pack_store.S + with type hash := Hash.t + and type key = Hash.t Pack_key.t + and type dispatcher = Dispatcher.t +end + +module type Sigs = sig + module Make (Args : Args) : sig + open Args + + module Export : sig + type t + + val v : Irmin.config -> read Contents_pack.t -> read Inode.Pack.t -> t + + val run : + ?on_disk:[ `Path of string ] -> + t -> + (Contents_pack.value -> unit Lwt.t) -> + (Inode.Snapshot.inode -> unit Lwt.t) -> + Hash.t Pack_key.t * Pack_value.Kind.t -> + int Lwt.t + + val close : + t -> + ( unit, + [> `Double_close + | `Index_failure of string + | `Io_misc of Fm.Io.misc_error + | `Pending_flush ] ) + result + end + + module Import : sig + type t + + val v : + ?on_disk:[ `Path of string | `Reuse ] -> + int -> + read Contents_pack.t -> + read Inode.Pack.t -> + t + + val save_contents : t -> Contents_pack.value -> Hash.t Pack_key.t Lwt.t + val save_inodes : t -> Inode.Snapshot.inode -> Hash.t Pack_key.t Lwt.t + val close : t -> unit + end + end +end diff --git a/vendors/irmin/src/irmin-pack/unix/stats.ml b/vendors/irmin/src/irmin-pack/unix/stats.ml new file mode 100644 index 0000000000000000000000000000000000000000..b73c315e51e1ea4633947e8b642f0d655cd81392 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/stats.ml @@ -0,0 +1,294 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Metrics = Irmin.Metrics + +module Pack_store = struct + type Metrics.origin += Pack_store_stats + + type field = + | Appended_hashes + | Appended_offsets + | Staging + | Lru + | Pack_direct + | Pack_indexed + | Not_found + [@@deriving irmin] + + type t = { + mutable appended_hashes : int; + mutable appended_offsets : int; + mutable total : int; + mutable from_staging : int; + mutable from_lru : int; + mutable from_pack_direct : int; + mutable from_pack_indexed : int; + } + [@@deriving irmin] + + type stat = t Metrics.t + + let create_pack_store () = + { + appended_hashes = 0; + appended_offsets = 0; + total = 0; + from_staging = 0; + from_lru = 0; + from_pack_direct = 0; + from_pack_indexed = 0; + } + + let init () = + let initial_state = create_pack_store () in + Metrics.v ~origin:Pack_store_stats ~name:"pack_store_metric" ~initial_state + t + + let clear m = + let v = Metrics.state m in + v.appended_hashes <- 0; + v.appended_offsets <- 0; + v.total <- 0; + v.from_staging <- 0; + v.from_lru <- 0; + v.from_pack_direct <- 0; + v.from_pack_indexed <- 0 + + let export m = Metrics.state m + + let update ~field finds = + let f v = + match field with + | Appended_hashes -> v.appended_hashes <- succ v.appended_hashes + | Appended_offsets -> v.appended_offsets <- succ v.appended_offsets + | Staging -> + v.total <- succ v.total; + v.from_staging <- succ v.from_staging + | Lru -> + v.total <- succ v.total; + v.from_lru <- succ v.from_lru + | Pack_direct -> + v.total <- succ v.total; + v.from_pack_direct <- succ v.from_pack_direct + | Pack_indexed -> + v.total <- succ v.total; + v.from_pack_indexed <- succ v.from_pack_indexed + | Not_found -> + v.total <- succ v.total; + () + in + let mut = Metrics.Mutate f in + Metrics.update finds mut + + let cache_misses + { + (* Total finds (hits + misses): *) + total; + (* In-memory hits: *) + from_staging; + from_lru; + _; + } = + total - (from_staging + from_lru) +end + +module Index = struct + module S = Index.Stats + + type Metrics.origin += Index_stats + + type t = Index.Stats.t = { + mutable bytes_read : int; + mutable nb_reads : int; + mutable bytes_written : int; + mutable nb_writes : int; + mutable nb_merge : int; + mutable merge_durations : float list; + mutable nb_replace : int; + mutable replace_durations : float list; + mutable nb_sync : int; + mutable time_sync : float; + mutable lru_hits : int; + mutable lru_misses : int; + } + [@@deriving irmin] + + type stat = t Metrics.t + + let create_index () = + { + bytes_read = 0; + nb_reads = 0; + bytes_written = 0; + nb_writes = 0; + nb_merge = 0; + merge_durations = []; + nb_replace = 0; + replace_durations = []; + nb_sync = 0; + time_sync = 0.0; + lru_hits = 0; + lru_misses = 0; + } + + let clear (data : stat) = + let s = Metrics.state data in + s.bytes_read <- 0; + s.nb_reads <- 0; + s.bytes_written <- 0; + s.nb_writes <- 0; + s.nb_merge <- 0; + s.merge_durations <- []; + s.nb_replace <- 0; + s.replace_durations <- []; + s.nb_sync <- 0; + s.time_sync <- 0.0; + s.lru_hits <- 0; + s.lru_misses <- 0 + + let init () = + let initial_state = create_index () in + Metrics.v ~origin:Index_stats ~name:"index_metric" ~initial_state t + + let report index = + let modifier = Metrics.Replace (fun _ -> Index.Stats.get ()) in + Metrics.(update index modifier) + + let export m = Metrics.state m +end + +module File_manager = struct + type Metrics.origin += File_manager + + type t = { + mutable dict_flushes : int; + mutable suffix_flushes : int; + mutable index_flushes : int; + mutable auto_dict : int; + mutable auto_suffix : int; + mutable auto_index : int; + mutable flush : int; + } + [@@deriving irmin] + + (* NOTE return a new instance each time, since fields are mutable *) + let create () = + { + dict_flushes = 0; + suffix_flushes = 0; + index_flushes = 0; + auto_dict = 0; + auto_suffix = 0; + auto_index = 0; + flush = 0; + } + + (* NOTE type [stat] is an abstract type in stats.mli *) + type stat = t Metrics.t + + let init () : stat = + let initial_state = create () in + Metrics.v ~origin:File_manager ~name:"file_manager_metric" ~initial_state t + + (* [export] reveals the [t] contained in the [Metrics.t] container *) + let export : stat -> t = fun m -> Metrics.state m + + (* support [reset_stats] function below *) + let clear' (t : t) = + t.dict_flushes <- 0; + t.suffix_flushes <- 0; + t.index_flushes <- 0; + () + + let clear (t : stat) = clear' (export t) + + (* we want to support an interface where the particular fields of type [t] are reified + as variants, so that we can call [incr_fm_field Dict_flushes] for example *) + + type field = + | Dict_flushes + | Suffix_flushes + | Index_flushes + | Auto_dict + | Auto_suffix + | Auto_index + | Flush + + let update ~field t = + let f t = + match field with + | Dict_flushes -> t.dict_flushes <- t.dict_flushes + 1 + | Suffix_flushes -> t.suffix_flushes <- t.suffix_flushes + 1 + | Index_flushes -> t.index_flushes <- t.index_flushes + 1 + | Auto_dict -> t.auto_dict <- t.auto_dict + 1 + | Auto_suffix -> t.auto_suffix <- t.auto_suffix + 1 + | Auto_index -> t.auto_index <- t.auto_index + 1 + | Flush -> t.flush <- t.flush + 1 + in + Metrics.update t (Metrics.Mutate f) +end + +type t = { + pack_store : Pack_store.stat; + index : Index.stat; + file_manager : File_manager.stat; +} + +let s = + { + pack_store = Pack_store.init (); + index = Index.init (); + file_manager = File_manager.init (); + } + +let reset_stats () = + Pack_store.clear s.pack_store; + Index.clear s.index; + File_manager.clear s.file_manager; + () + +let get () = s +let report_pack_store ~field = Pack_store.update ~field s.pack_store +let report_index () = Index.report s.index + +let incr_appended_hashes () = + Pack_store.update ~field:Pack_store.Appended_hashes s.pack_store + +let incr_appended_offsets () = + Pack_store.update ~field:Pack_store.Appended_offsets s.pack_store + +type cache_stats = { cache_misses : float } +type offset_stats = { offset_ratio : float; offset_significance : int } + +let div_or_zero a b = if b = 0 then 0. else float_of_int a /. float_of_int b + +let get_cache_stats () = + let pack_store = Metrics.state s.pack_store in + let cache_misses = Pack_store.cache_misses pack_store in + { cache_misses = div_or_zero cache_misses pack_store.total } + +let get_offset_stats () = + let pack_store = Metrics.state s.pack_store in + { + offset_ratio = + div_or_zero pack_store.appended_offsets + (pack_store.appended_offsets + pack_store.appended_hashes); + offset_significance = + pack_store.appended_offsets + pack_store.appended_hashes; + } + +let incr_fm_field field = File_manager.update ~field s.file_manager diff --git a/vendors/irmin/src/irmin-pack/unix/stats.mli b/vendors/irmin/src/irmin-pack/unix/stats.mli new file mode 100644 index 0000000000000000000000000000000000000000..3bc36e5d399eb7e11fb35ecc67b220771ebc3f01 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/stats.mli @@ -0,0 +1,149 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Pack_store : sig + type field = + | Appended_hashes + | Appended_offsets + | Staging (** Found in the store's write buffer. *) + | Lru (** Found in the store's LRU of recent [find] results. *) + | Pack_direct + (** Decoded directly from the pack file (via a direct key). *) + | Pack_indexed + (** Binding recovered from the pack file after first checking the index + for its offset and length (via an indexed key). *) + | Not_found (** Find returned [None]. *) + [@@deriving irmin] + + type t = private { + mutable appended_hashes : int; + mutable appended_offsets : int; + mutable total : int; + mutable from_staging : int; + mutable from_lru : int; + mutable from_pack_direct : int; + mutable from_pack_indexed : int; + } + [@@deriving irmin] + + type stat + + val cache_misses : t -> int + val export : stat -> t +end + +module Index : sig + type t = Index.Stats.t = private { + mutable bytes_read : int; + mutable nb_reads : int; + mutable bytes_written : int; + mutable nb_writes : int; + mutable nb_merge : int; + mutable merge_durations : float list; + mutable nb_replace : int; + mutable replace_durations : float list; + mutable nb_sync : int; + mutable time_sync : float; + mutable lru_hits : int; + mutable lru_misses : int; + } + [@@deriving irmin] + + type stat + + val export : stat -> t +end + +module File_manager : sig + type field = + | Dict_flushes + | Suffix_flushes + | Index_flushes + | Auto_dict + | Auto_suffix + | Auto_index + | Flush + + type t = private { + mutable dict_flushes : int; + mutable suffix_flushes : int; + mutable index_flushes : int; + mutable auto_dict : int; + mutable auto_suffix : int; + mutable auto_index : int; + mutable flush : int; + } + [@@deriving irmin] + + type stat + + val export : stat -> t +end + +type t = { + pack_store : Pack_store.stat; + index : Index.stat; + file_manager : File_manager.stat; +} +(** Record type for all statistics that will be collected. There is a single + instance (which we refer to as "the instance" below) which is returned by + {!get}. *) + +val reset_stats : unit -> unit +(** [reset_stats ()] will call the relevant [clear] function on each field of + the instance. This typically resets the fields (e.g. to 0 for an int field). *) + +val get : unit -> t +(** [get ()] returns the instance of {!t} that stores the satistics. If + {!report_pack_store} or {!report_index} is not called before, the content + will be filled with default value, decided at create time (most the time, + [0]). *) + +val report_pack_store : field:Pack_store.field -> unit +(** [report_pack_store ~field] increments the [field] value in the [pack_store] + stats. It also increments the [total] field in {!Pack_store.t} when the + field is related to [finds]. *) + +val report_index : unit -> unit +(** [report_index ()] fills the [stats] with value from the {!Index.Stats} + module. This essentially copies the "current" values from {!Index.Stats} to + the [get()] instance [index] field. *) + +val incr_appended_hashes : unit -> unit +(** [incr_appended_hashes ()] increments the field [appended_hashes] for + [pack_store] in the instance. *) + +val incr_appended_offsets : unit -> unit +(** [incr_appended_offsets] increments the field [appended_offsets] for + [pack_store] in the instance. *) + +type cache_stats = { cache_misses : float } + +type offset_stats = { offset_ratio : float; offset_significance : int } +(** [offset_ratio]: [appended_offsets / (appended_offsets + appended_hashes)]; + [offset_significance]: [appended_offsets + appended_hashes] *) + +val get_cache_stats : unit -> cache_stats +(** [get_cache_stats()] uses the instance [pack_store] field to compute cache + misses. *) + +val get_offset_stats : unit -> offset_stats +(** [get_offset_stats()] uses the instance [pack_store] field to compute offset + stats. *) + +val incr_fm_field : File_manager.field -> unit +(** [incr_fm_field field] increments the chosen stats field for the + {!File_manager} *) diff --git a/vendors/irmin/src/irmin-pack/unix/traverse_pack_file.ml b/vendors/irmin/src/irmin-pack/unix/traverse_pack_file.ml new file mode 100644 index 0000000000000000000000000000000000000000..760120d37ae5777c3b87c8a2dd635dd8e2fce83d --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/traverse_pack_file.ml @@ -0,0 +1,361 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module Io = Io.Unix + +module Stats : sig + type t + + val empty : unit -> t + val add : t -> Pack_value.Kind.t -> unit + val duplicate_entry : t -> unit + val missing_hash : t -> unit + val pp : t Fmt.t +end = struct + module Kind = Pack_value.Kind + + type t = { + pack_values : int array; + mutable duplicates : int; + mutable missing_hashes : int; + } + + let empty () = + let pack_values = Array.make (List.length Kind.all) 0 in + { pack_values; duplicates = 0; missing_hashes = 0 } + + let incr t n = t.pack_values.(n) <- t.pack_values.(n) + 1 + let add t k = incr t (Kind.to_enum k) + let duplicate_entry t = t.duplicates <- t.duplicates + 1 + let missing_hash t = t.missing_hashes <- t.missing_hashes + 1 + + let pp = + let open Fmt.Dump in + let pack_values = + ListLabels.map Kind.all ~f:(fun k -> + let name = Fmt.str "%a" Kind.pp k in + let index = Kind.to_enum k in + field name (fun t -> t.pack_values.(index)) Fmt.int) + in + record + (pack_values + @ [ + field "Duplicated entries" (fun t -> t.duplicates) Fmt.int; + field "Missing entries" (fun t -> t.missing_hashes) Fmt.int; + ]) +end + +module type Args = sig + module File_manager : File_manager.S + module Hash : Irmin.Hash.S + module Index : Pack_index.S with type key := Hash.t + module Inode : Inode.S with type hash := Hash.t + module Dict : Dict.S + module Contents : Pack_value.S + module Commit : Pack_value.S +end + +module Make (Args : Args) : sig + val run : + [ `Reconstruct_index of [ `In_place | `Output of string ] + | `Check_index + | `Check_and_fix_index ] -> + Irmin.config -> + unit + + val test : + [ `Reconstruct_index of [ `In_place | `Output of string ] + | `Check_index + | `Check_and_fix_index ] -> + Irmin.config -> + unit +end = struct + open Args + module Errs = Io_errors.Make (Args.File_manager.Io) + + let pp_key = Irmin.Type.pp Hash.t + let decode_key = Irmin.Type.(unstage (decode_bin Hash.t)) + let decode_kind = Irmin.Type.(unstage (decode_bin Pack_value.Kind.t)) + + (* [Repr] doesn't yet support buffered binary decoders, so we hack one + together by re-interpreting [Invalid_argument _] exceptions from [Repr] + as requests for more data. *) + exception Not_enough_buffer + + type index_value = int63 * int * Pack_value.Kind.t + [@@deriving irmin ~equal ~pp] + + type index_binding = { key : Hash.t; data : index_value } + type missing_hash = { idx_pack : int; binding : index_binding } + + let pp_binding ppf x = + let off, len, kind = x.data in + Fmt.pf ppf "@[%a with hash %a@,pack offset = %a, length = %d@]" + Pack_value.Kind.pp kind pp_key x.key Int63.pp off len + + module Index_reconstructor = struct + let create ~dest config = + let dest = + match dest with + | `Output path -> + if Sys.file_exists path then + Fmt.invalid_arg "Can't reconstruct index. File already exits."; + path + | `In_place -> + if Conf.readonly config then raise Irmin_pack.RO_not_allowed; + Conf.root config + in + let log_size = Conf.index_log_size config in + [%log.app + "Beginning index reconstruction with parameters: { log_size = %d }" + log_size]; + let index = Index.v_exn ~fresh:true ~readonly:false ~log_size dest in + index + + let iter_pack_entry index key data = + Index.add index key data; + Ok () + + let finalise index () = + (* Ensure that the log file is empty, so that subsequent opens with a + smaller [log_size] don't immediately trigger a merge operation. *) + [%log.app "Completed indexing of pack entries. Running a final merge ..."]; + Index.try_merge index; + Index.close_exn index + end + + module Index_checker = struct + let create config = + let log_size = Conf.index_log_size config in + [%log.app + "Beginning index checking with parameters: { log_size = %d }" log_size]; + let index = + Index.v_exn ~fresh:false ~readonly:true ~log_size (Conf.root config) + in + (index, ref 0) + + let iter_pack_entry (index, idx_ref) key data = + match Index.find index key with + | None -> + Error (`Missing_hash { idx_pack = !idx_ref; binding = { key; data } }) + | Some data' when not @@ equal_index_value data data' -> + Error `Inconsistent_entry + | Some _ -> + incr idx_ref; + Ok () + + let finalise (index, _) () = Index.close_exn index + end + + module Index_check_and_fix = struct + let create config = + let log_size = Conf.index_log_size config in + [%log.app + "Beginning index checking with parameters: { log_size = %d }" log_size]; + let root = Conf.root config in + let index = Index.v_exn ~fresh:false ~readonly:false ~log_size root in + (index, ref 0) + + let iter_pack_entry (index, idx_ref) key data = + match Index.find index key with + | None -> + Index.add index key data; + Error (`Missing_hash { idx_pack = !idx_ref; binding = { key; data } }) + | Some data' when not @@ equal_index_value data data' -> + Error `Inconsistent_entry + | Some _ -> + incr idx_ref; + Ok () + + let finalise (index, _) () = + [%log.app "Completed indexing of pack entries. Running a final merge ..."]; + Index.try_merge index; + Index.close_exn index + end + + let decode_entry_length = function + | Pack_value.Kind.Contents -> Contents.decode_bin_length + | Commit_v1 | Commit_v2 -> Commit.decode_bin_length + | Inode_v1_stable | Inode_v1_unstable | Inode_v2_root | Inode_v2_nonroot -> + Inode.decode_bin_length + | Dangling_parent_commit -> assert false + + let decode_entry_exn ~off ~buffer ~buffer_off = + try + let buffer_pos = ref buffer_off in + (* Decode the key and kind by hand *) + let key = decode_key buffer buffer_pos in + assert (!buffer_pos = buffer_off + Hash.hash_size); + let kind = decode_kind buffer buffer_pos in + assert (!buffer_pos = buffer_off + Hash.hash_size + 1); + (* Get the length of the entire entry *) + let entry_len = decode_entry_length kind buffer buffer_off in + { key; data = (off, entry_len, kind) } + with + | Invalid_argument msg when msg = "index out of bounds" -> + raise Not_enough_buffer + | Invalid_argument msg when msg = "String.blit / Bytes.blit_string" -> + raise Not_enough_buffer + + (* Read at most [len], by checking that [(off, len)] don't go out of bounds of + the suffix file. *) + let io_read_at_most ~off ~len b suffix = + let bytes_after_off = + let open Int63.Syntax in + File_manager.Suffix.end_offset suffix - off + in + let len = + let open Int63.Syntax in + if bytes_after_off < Int63.of_int len then Int63.to_int bytes_after_off + else len + in + File_manager.Suffix.read_exn suffix ~off ~len b; + len + + let ingest_data_file ~initial_buffer_size ~progress ~total suffix + iter_pack_entry = + let buffer = ref (Bytes.create initial_buffer_size) in + let refill_buffer ~from = + let buffer_len = Bytes.length !buffer in + let (_ : int) = + io_read_at_most ~off:from ~len:buffer_len !buffer suffix + in + () + in + let expand_and_refill_buffer ~from = + let length = Bytes.length !buffer in + if length > 1_000_000_000 (* 1 GB *) then + Fmt.failwith + "Couldn't decode the value at offset %a in %d of buffer space. \ + Corrupted data file?" + Int63.pp from length + else ( + buffer := Bytes.create (2 * length); + refill_buffer ~from) + in + let stats = Stats.empty () in + let rec loop_entries ~buffer_off off missing_hash = + if off >= total then (stats, missing_hash) + else + let buffer_off, off, missing_hash = + match + (* Bytes.unsafe_to_string usage: possibly safe, depending on details of + implementation of decode_entry_exn TODO either justify clearly that this is + safe, or change to use safe Bytes.to_string *) + decode_entry_exn ~off + ~buffer:(Bytes.unsafe_to_string !buffer) + ~buffer_off + with + | { key; data } -> + let off', entry_len, kind = data in + let entry_lenL = Int63.of_int entry_len in + assert (off = off'); + [%log.debug + "k = %a (off, len, kind) = (%a, %d, %a)" pp_key key Int63.pp off + entry_len Pack_value.Kind.pp kind]; + Stats.add stats kind; + let missing_hash = + match iter_pack_entry key data with + | Ok () -> Option.map Fun.id missing_hash + | Error `Inconsistent_entry -> + Stats.duplicate_entry stats; + Option.map Fun.id missing_hash + | Error (`Missing_hash x) -> + Stats.missing_hash stats; + Some x + in + let off = Int63.Syntax.(off + entry_lenL) in + progress entry_lenL; + (buffer_off + entry_len, off, missing_hash) + | exception Not_enough_buffer -> + let () = + if buffer_off > 0 then + (* Try again with the value at the start of the buffer. *) + refill_buffer ~from:off + else + (* The entire buffer isn't enough to hold this value: expand it. *) + expand_and_refill_buffer ~from:off + in + (0, off, missing_hash) + in + loop_entries ~buffer_off off missing_hash + in + refill_buffer ~from:Int63.zero; + loop_entries ~buffer_off:0 Int63.zero None + + let run_or_test ~initial_buffer_size mode config = + let iter_pack_entry, finalise, message = + match mode with + | `Reconstruct_index dest -> + let open Index_reconstructor in + let v = create ~dest config in + (iter_pack_entry v, finalise v, "Reconstructing index") + | `Check_index -> + let open Index_checker in + let v = create config in + (iter_pack_entry v, finalise v, "Checking index") + | `Check_and_fix_index -> + let open Index_check_and_fix in + let v = create config in + (iter_pack_entry v, finalise v, "Checking and fixing index") + in + let run_duration = Mtime_clock.counter () in + let fm = File_manager.open_ro config |> Errs.raise_if_error in + let suffix = File_manager.suffix fm in + let total = File_manager.Suffix.end_offset suffix in + let stats, missing_hash = + let bar = + let open Progress.Line.Using_int63 in + list + [ const message; bytes; elapsed (); bar total; percentage_of total ] + in + Progress.(with_reporter bar) (fun progress -> + ingest_data_file ~initial_buffer_size ~progress ~total suffix + iter_pack_entry) + in + finalise (); + File_manager.close fm |> Errs.raise_if_error; + let run_duration = Mtime_clock.count run_duration in + let store_stats fmt = + Fmt.pf fmt "Store statistics:@, @[%a@]" Stats.pp stats + in + match missing_hash with + | None -> + [%log.app + "%a in %a. %t" + Fmt.(styled `Green string) + "Success" Mtime.Span.pp run_duration store_stats] + | Some x -> + let msg = + match mode with + | `Check_index -> "Detected missing entries" + | `Check_and_fix_index -> + "Detected missing entries and added them to index" + | _ -> assert false + in + [%log.err + "%a in %a.@,\ + First pack entry missing from index is the %d entry of the pack:@,\ + \ %a@,\ + %t" + Fmt.(styled `Red string) + msg Mtime.Span.pp run_duration x.idx_pack pp_binding x.binding + store_stats] + + let run = run_or_test ~initial_buffer_size:1024 + let test = run_or_test ~initial_buffer_size:100 +end diff --git a/vendors/irmin/src/irmin-pack/unix/utils.ml b/vendors/irmin/src/irmin-pack/unix/utils.ml new file mode 100644 index 0000000000000000000000000000000000000000..a7bcdf8126481b4d0080c4e8b60849b9a8c7e6f7 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/unix/utils.ml @@ -0,0 +1,62 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Object_counter : sig + type t + + val start : unit -> t * ((unit -> unit) * (unit -> unit) * (unit -> unit)) + val finalise : t -> unit + val finalise_with_stats : t -> int * int * int +end = struct + type t = + | Object_counter : { + display : (_, _) Progress.Display.t; + nb_commits : int ref; + nb_nodes : int ref; + nb_contents : int ref; + } + -> t + + let start () = + let nb_commits = ref 0 in + let nb_nodes = ref 0 in + let nb_contents = ref 0 in + let bar = + let open Progress.Line in + let count_to_string (contents, nodes, commits) = + Fmt.str "%dk contents / %dk nodes / %d commits" (contents / 1000) + (nodes / 1000) commits + in + using count_to_string string + in + let display = Progress.Display.start (Progress.Multi.line bar) in + let [ reporter ] = Progress.Display.reporters display in + let update_fn count () = + incr count; + reporter (!nb_contents, !nb_nodes, !nb_commits) + in + let contents = update_fn nb_contents + and nodes = update_fn nb_nodes + and commits = update_fn nb_commits in + ( Object_counter { display; nb_contents; nb_nodes; nb_commits }, + (contents, nodes, commits) ) + + let finalise (Object_counter t) = Progress.Display.finalise t.display + + let finalise_with_stats (Object_counter t as t_outer) = + finalise t_outer; + (!(t.nb_contents), !(t.nb_nodes), !(t.nb_commits)) +end diff --git a/vendors/irmin/src/irmin-pack/version.ml b/vendors/irmin/src/irmin-pack/version.ml new file mode 100644 index 0000000000000000000000000000000000000000..fb296b935001ad2403c54992ed09e6ec91c27bdf --- /dev/null +++ b/vendors/irmin/src/irmin-pack/version.ml @@ -0,0 +1,62 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* For every new version, update the [version] type and [versions] + headers. *) + +type t = [ `V1 | `V2 | `V3 ] [@@deriving irmin] + +let latest = `V3 +let enum = [ (`V1, "00000001"); (`V2, "00000002"); (`V3, "00000003") ] +let pp = Fmt.of_to_string (function `V1 -> "v1" | `V2 -> "v2" | `V3 -> "v3") +let to_bin v = List.assoc v enum +let to_int = function `V1 -> 1 | `V2 -> 2 | `V3 -> 3 +let compare a b = Int.compare (to_int a) (to_int b) +let encode_bin t f = to_bin t |> f + +let decode_bin s offref = + let sub = String.sub s !offref (!offref + 8) in + let res = + match sub with + | "00000001" -> `V1 + | "00000002" -> `V2 + | "00000003" -> `V3 + | _ -> failwith "Couldn't decode pack version" + in + offref := !offref + 8; + res + +let size_of = Irmin.Type.Size.custom_static 8 +let bin = (encode_bin, decode_bin, size_of) +let t = Irmin.Type.like ~bin ~unboxed_bin:bin ~compare ~pp t + +let invalid_arg v = + let pp_full_version ppf v = Fmt.pf ppf "%a (%S)" pp v (to_bin v) in + Fmt.invalid_arg "invalid version: got %S, expecting %a" v + Fmt.(Dump.list pp_full_version) + (List.map fst enum) + +let of_bin b = try Some (decode_bin b (ref 0)) with Failure _ -> None + +exception Invalid of { expected : t; found : t } + +let () = + Printexc.register_printer (function + | Invalid { expected; found } -> + Some + (Fmt.str "%s.Invalid { expected = %a; found = %a }" __MODULE__ pp + expected pp found) + | _ -> None) diff --git a/vendors/irmin/src/irmin-pack/version.mli b/vendors/irmin/src/irmin-pack/version.mli new file mode 100644 index 0000000000000000000000000000000000000000..5480eb7b281718c6afb1ac787b27d9f878fd3ad6 --- /dev/null +++ b/vendors/irmin/src/irmin-pack/version.mli @@ -0,0 +1,47 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Management of disk-format versions. + + [`V2] introduced the [*_v2] kinds and deprecated the [*_v1] ones. The + upgrade of a pack file to [`V2] was done silently the first time a used + pushed a [*_v2] entry to the pack file. + + [`V3] introduced the control file. It centralizes all the metadata that used + to be contained in the header of other files (e.g. the version of the store + used to be stored in each files, it is now solely stored in the control + file). The upgrade of a store to [`V3] was done silently when opening a + store in rw mode. *) + +type t = [ `V1 | `V2 | `V3 ] [@@deriving irmin] +(** The type for version numbers. *) + +val compare : t -> t -> int +val latest : t + +val pp : t Fmt.t +(** [pp] is the pretty-format for version numbers. *) + +val to_bin : t -> string +(** [to_bin t] is the 8-bytes binary representation of [t]. *) + +val of_bin : string -> t option +(** [of_bin s] is [Some t] is [to_bin t] is [s] and [None] otherwise. *) + +val invalid_arg : string -> 'a +(** [invalid_arg str] raises [Invalid_argument]. *) + +exception Invalid of { expected : t; found : t } diff --git a/vendors/irmin/src/irmin-test/common.ml b/vendors/irmin/src/irmin-test/common.ml new file mode 100644 index 0000000000000000000000000000000000000000..01436177bbdb3c098689af6027f5aa36598f8dd7 --- /dev/null +++ b/vendors/irmin/src/irmin-test/common.ml @@ -0,0 +1,324 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +let random_char () = char_of_int (Random.int 256) + +let random_ascii () = + let chars = "0123456789abcdefghijklmnopqrstABCDEFGHIJKLMNOPQRST-_." in + chars.[Random.int @@ String.length chars] + +let random_string n = String.init n (fun _i -> random_char ()) +let long_random_string = random_string (* 1024_000 *) 10 +let random_ascii_string n = String.init n (fun _i -> random_ascii ()) +let long_random_ascii_string = random_ascii_string 1024_000 + +let merge_exn msg x = + match x with + | Ok x -> Lwt.return x + | Error (`Conflict m) -> Alcotest.failf "%s: %s" msg m + +open Astring + +module type S = + Irmin.S + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Contents.t = string + and type Schema.Branch.t = string + +module type Generic_key = + Irmin.Generic_key.S + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Contents.t = string + and type Schema.Branch.t = string + +module Schema = struct + module Hash = Irmin.Hash.SHA1 + module Commit = Irmin.Commit.Make (Hash) + module Path = Irmin.Path.String_list + module Metadata = Irmin.Metadata.None + module Node = Irmin.Node.Generic_key.Make (Hash) (Path) (Metadata) + module Branch = Irmin.Branch.String + module Info = Irmin.Info.Default + module Contents = Irmin.Contents.String +end + +let store : (module Irmin.Maker) -> (module Irmin.Metadata.S) -> (module S) = + fun (module B) (module M) -> + let module Schema = struct + include Schema + module Metadata = M + module Node = Irmin.Node.Generic_key.Make (Hash) (Path) (Metadata) + end in + let module S = B.Make (Schema) in + (module S) + +type store = S of (module S) | Generic_key of (module Generic_key) + +type t = { + name : string; + init : config:Irmin.config -> unit Lwt.t; + clean : config:Irmin.config -> unit Lwt.t; + config : Irmin.config; + store : store; + stats : (unit -> int * int) option; + (* Certain store implementations currently don't support implementing + repository state from a slice, because their slice formats contain + non-portable objects. For now, we disable the tests require this feature + for such backends. + + TODO: fix slices to always contain portable objects, and extend + [Store.import] to re-hydrate the keys in these slices (by tracking keys of + added objects), then require all backends to run thee tests. *) + import_supported : bool; +} + +module Suite = struct + type nonrec t = t + + let default_clean ~config ~store = + let (module Store : Generic_key) = + match store with + | Generic_key x -> x + | S (module S) -> (module S : Generic_key) + in + let open Lwt.Syntax in + let* repo = Store.Repo.v config in + let* branches = Store.Repo.branches repo in + let* () = Lwt_list.iter_p (Store.Branch.remove repo) branches in + Store.Repo.close repo + + let create ~name ?(init = fun ~config:_ -> Lwt.return_unit) ?clean ~config + ~store ?stats ?(import_supported = true) () = + let store = S store in + let clean = Option.value clean ~default:(default_clean ~store) in + { name; init; clean; config; store; stats; import_supported } + + let create_generic_key ~name ?(init = fun ~config:_ -> Lwt.return_unit) ?clean + ~config ~store ?stats ?(import_supported = true) () = + let store = Generic_key store in + let clean = Option.value clean ~default:(default_clean ~store) in + { name; init; clean; config; store; stats; import_supported } + + let name t = t.name + let config t = t.config + let store t = match t.store with S x -> Some x | Generic_key _ -> None + + let store_generic_key t = + match t.store with + | Generic_key x -> x + | S (module S) -> (module S : Generic_key) + + let init t = t.init + let clean t = t.clean +end + +module type Store_tests = functor (S : Generic_key) -> sig + val tests : (string * (Suite.t -> unit -> unit Lwt.t)) list +end + +module Make_helpers (S : Generic_key) = struct + module B = S.Backend + module Graph = Irmin.Node.Graph (B.Node) + + let info message = + let date = Int64.of_float 0. in + let author = Printf.sprintf "TESTS" in + S.Info.v ~author ~message date + + let infof fmt = Fmt.kstr (fun str () -> info str) fmt + + let get_contents_key = function + | `Contents key -> key + | _ -> Alcotest.fail "expecting contents_key" + + let get_node_key = function + | `Node key -> key + | _ -> Alcotest.fail "expecting node_key" + + type x = int [@@deriving irmin] + + let v repo = B.Repo.contents_t repo + let n repo = B.Repo.node_t repo + let ct repo = B.Repo.commit_t repo + let g repo = B.Repo.node_t repo + let h repo = B.Repo.commit_t repo + let b repo = B.Repo.branch_t repo + let v1 = long_random_string + let v2 = "" + let with_contents repo f = B.Repo.batch repo (fun t _ _ -> f t) + let with_node repo f = B.Repo.batch repo (fun _ t _ -> f t) + let with_commit repo f = B.Repo.batch repo (fun _ _ t -> f t) + let with_info repo n f = with_commit repo (fun h -> f h ~info:(info n)) + let kv1 ~repo = with_contents repo (fun t -> B.Contents.add t v1) + let kv2 ~repo = with_contents repo (fun t -> B.Contents.add t v2) + let normal x = `Contents (x, S.Metadata.default) + let b1 = "foo" + let b2 = "bar/toto" + + let n1 ~repo = + let* kv1 = kv1 ~repo in + with_node repo (fun t -> Graph.v t [ ("x", normal kv1) ]) + + let n2 ~repo = + let* kn1 = n1 ~repo in + with_node repo (fun t -> Graph.v t [ ("b", `Node kn1) ]) + + let n3 ~repo = + let* kn2 = n2 ~repo in + with_node repo (fun t -> Graph.v t [ ("a", `Node kn2) ]) + + let n4 ~repo = + let* kn1 = n1 ~repo in + let* kv2 = kv2 ~repo in + let* kn4 = with_node repo (fun t -> Graph.v t [ ("x", normal kv2) ]) in + let* kn5 = + with_node repo (fun t -> Graph.v t [ ("b", `Node kn1); ("c", `Node kn4) ]) + in + with_node repo (fun t -> Graph.v t [ ("a", `Node kn5) ]) + + let r1 ~repo = + let* kn2 = n2 ~repo in + S.Tree.of_key repo (`Node kn2) >>= function + | None -> Alcotest.fail "r1" + | Some tree -> + S.Commit.v repo ~info:S.Info.empty ~parents:[] (tree :> S.tree) + + let r2 ~repo = + let* kn3 = n3 ~repo in + let* kr1 = r1 ~repo in + S.Tree.of_key repo (`Node kn3) >>= function + | None -> Alcotest.fail "r2" + | Some t3 -> + S.Commit.v repo ~info:S.Info.empty + ~parents:[ S.Commit.key kr1 ] + (t3 :> S.tree) + + let ignore_thunk_errors f = Lwt.catch f (fun _ -> Lwt.return_unit) + + let run (x : Suite.t) test = + let repo_ptr = ref None in + let config_ptr = ref None in + Lwt.catch + (fun () -> + let module Conf = Irmin.Backend.Conf in + let generate_random_root config = + let id = Random.int 100 |> string_of_int in + let root_value = + match Conf.find_root config with + | None -> "test_" ^ id + | Some v -> v ^ "_" ^ id + in + let root_key = Conf.(root (spec config)) in + Conf.add config root_key root_value + in + let config = generate_random_root x.config in + config_ptr := Some config; + let* () = x.init ~config in + let* repo = S.Repo.v config in + repo_ptr := Some repo; + let* () = test repo in + let* () = + (* [test] might have already closed the repo. That + [ignore_thunk_errors] shall be removed as soon as all stores + support double closes. *) + ignore_thunk_errors (fun () -> S.Repo.close repo) + in + x.clean ~config) + (fun exn -> + (* [test] failed, attempt an errorless cleanup and forward the right + backtrace to the user. *) + let bt = Printexc.get_raw_backtrace () in + let* () = + match !repo_ptr with + | Some repo -> ignore_thunk_errors (fun () -> S.Repo.close repo) + | None -> Lwt.return_unit + in + let+ () = + match !config_ptr with + | Some config -> ignore_thunk_errors (fun () -> x.clean ~config) + | None -> Lwt.return_unit + in + Printexc.raise_with_backtrace exn bt) +end + +let filter_src src = + not + (List.mem ~equal:String.equal (Logs.Src.name src) + [ + "git.inflater.decoder"; + "git.deflater.encoder"; + "git.encoder"; + "git.decoder"; + "git.loose"; + "git.store"; + "cohttp.lwt.io"; + ]) + +let reporter ?prefix () = + Irmin.Export_for_backends.Logging.reporter ~filter_src ?prefix + (module Mtime_clock) + +let () = + Logs.set_level (Some Logs.Debug); + Logs.set_reporter (reporter ()) + +let line ppf ?color c = + let line = String.v ~len:80 (fun _ -> c) in + match color with + | Some c -> Fmt.pf ppf "%a\n%!" Fmt.(styled c string) line + | None -> Fmt.pf ppf "%s\n%!" line + +let line msg = + let line () = line Fmt.stderr ~color:`Yellow '-' in + line (); + [%logs.info "ASSERT %s" msg]; + line () + +let ( / ) = Filename.concat + +let testable t = + Alcotest.testable (Irmin.Type.pp_dump t) Irmin.Type.(unstage (equal t)) + +let check t = Alcotest.check (testable t) + +let checks t = + let t = Alcotest.slist (testable t) Irmin.Type.(unstage (compare t)) in + Alcotest.check t + +(* also in test/irmin-pack/common.ml *) +let check_raises_lwt msg exn (type a) (f : unit -> a Lwt.t) = + Lwt.catch + (fun x -> + let* (_ : a) = f x in + Alcotest.failf + "Fail %s: expected function to raise %s, but it returned instead." msg + (Printexc.to_string exn)) + (function + | e when e = exn -> Lwt.return_unit + | e -> + Alcotest.failf + "Fail %s: expected function to raise %s, but it raised %s instead." + msg (Printexc.to_string exn) (Printexc.to_string e)) + +module T = Irmin.Type + +module type Sleep = sig + val sleep : float -> unit Lwt.t +end diff --git a/vendors/irmin/src/irmin-test/dune b/vendors/irmin/src/irmin-test/dune new file mode 100644 index 0000000000000000000000000000000000000000..7fbcdc1c4584aea7a20fc5179517491268716da2 --- /dev/null +++ b/vendors/irmin/src/irmin-test/dune @@ -0,0 +1,40 @@ +(library + (name irmin_test) + (public_name irmin-test) + (modules Irmin_test Node Store Store_graph Store_watch Common Import) + (preprocess + (pps ppx_irmin.internal)) + (libraries + alcotest-lwt + astring + fmt + irmin + jsonm + logs.fmt + lwt + mtime + mtime.clock.os) + (instrumentation + (backend bisect_ppx))) + +(library + (foreign_stubs + (language c) + (names rusage_stubs)) + (name irmin_bench) + (public_name irmin-test.bench) + (modules Irmin_bench Rusage) + (libraries + fmt.tty + fmt.cli + cmdliner + irmin + logs.fmt + logs.cli + lwt + lwt.unix + metrics + metrics-unix + irmin-test) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-test/helpers.ml b/vendors/irmin/src/irmin-test/helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..c2593ec7a605f8453021eb45c105e2480eaae7ee --- /dev/null +++ b/vendors/irmin/src/irmin-test/helpers.ml @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let init_logs () = + Logs.set_level (Some Debug); + Logs.set_reporter (Common.reporter ()) diff --git a/vendors/irmin/src/irmin-test/import.ml b/vendors/irmin/src/irmin-test/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..71053e21ba54118af9da1fc7b37d45eb620c46e2 --- /dev/null +++ b/vendors/irmin/src/irmin-test/import.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/src/irmin-test/irmin_bench.ml b/vendors/irmin/src/irmin-test/irmin_bench.ml new file mode 100644 index 0000000000000000000000000000000000000000..6b3872882cc8c2da2d642f836ab40fa21b4a9526 --- /dev/null +++ b/vendors/irmin/src/irmin-test/irmin_bench.ml @@ -0,0 +1,190 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2019 Etienne Millon + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Export_for_backends + +type t = { + root : string; + ncommits : int; + depth : int; + tree_add : int; + display : int; + clear : bool; + gc : int; +} + +type stats = { commits : int; size : int; maxrss : int } + +let src = + let open Metrics in + let tags = Tags.[] in + let data t = + Data.v + [ + int "commits" t.commits; + int "size" ~unit:"MiB" t.size; + int "maxrss" ~unit:"MiB" t.maxrss; + ] + in + Src.v "bench" ~tags ~data + +(* cli *) + +open Cmdliner + +let deprecated_info = (Term.info [@alert "-deprecated"]) +let deprecated_exit = (Term.exit [@alert "-deprecated"]) +let deprecated_eval = (Term.eval [@alert "-deprecated"]) + +let log style_renderer level = + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (Irmin_test.reporter ()); + () + +let log = Term.(const log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) + +let ncommits = + let doc = Arg.info ~doc:"Number of iterations." [ "n"; "ncommits" ] in + Arg.(value @@ opt int 1000 doc) + +let depth = + let doc = Arg.info ~doc:"Depth of the tree." [ "d"; "depth" ] in + Arg.(value @@ opt int 30 doc) + +let tree_add = + let doc = + Arg.info ~doc:"Number of tree entries added per commit" [ "a"; "tree-add" ] + in + Arg.(value @@ opt int 1000 doc) + +let display = + let doc = + Arg.info ~doc:"Number of commits after which the stats are displayed." + [ "s"; "stats" ] + in + Arg.(value @@ opt int 10 doc) + +let gc = + let doc = + Arg.info ~doc:"Number of commits after which Gc.full_major is called." + [ "gc" ] + in + Arg.(value @@ opt int 100 doc) + +let clear = + let doc = Arg.info ~doc:"Clear the tree after each commit." [ "clear" ] in + Arg.(value @@ flag doc) + +let t = + Term.( + const (fun () ncommits depth tree_add display clear gc -> + { ncommits; depth; tree_add; display; root = "."; clear; gc }) + $ log + $ ncommits + $ depth + $ tree_add + $ display + $ clear + $ gc) + +module Make (Store : Irmin.Generic_key.KV with type Schema.Contents.t = string) = +struct + let info () = Store.Info.v ~author:"author" ~message:"commit message" 0L + + let times ~n ~init f = + let rec go i k = + if i = 0 then k init else go (i - 1) (fun r -> f i r >>= k) + in + go n Lwt.return + + let path ~depth n = + let rec aux acc = function + | i when i = depth -> List.rev (string_of_int n :: acc) + | i -> aux (string_of_int i :: acc) (i + 1) + in + aux [] 0 + + let get_maxrss () = + let usage = Rusage.get SELF in + let ( / ) = Int64.div in + Int64.to_int (usage.maxrss / 1024L / 1024L) + + let no_tags x = x + + let print_stats ~commits ~size = + let maxrss = get_maxrss () in + let size = size () in + Metrics.add src no_tags (fun f -> f { size; commits; maxrss }) + + let plot_progress n t = Fmt.epr "\rcommits: %4d/%d%!" n t + + (* init: create a tree with [t.depth] levels and each levels has + [t.tree_add] files + one directory going to the next levele. *) + let init t config = + let tree = Store.Tree.empty () in + let* v = Store.Repo.v config >>= Store.main in + let* tree = + times ~n:t.depth ~init:tree (fun depth tree -> + let paths = Array.init (t.tree_add + 1) (path ~depth) in + times ~n:t.tree_add ~init:tree (fun n tree -> + Store.Tree.add tree paths.(n) "init")) + in + Store.set_tree_exn v ~info [] tree >|= fun () -> Fmt.epr "[init done]\n%!" + + let run t config size = + let* r = Store.Repo.v config in + let* v = Store.main r in + Store.Tree.reset_counters (); + let paths = Array.init (t.tree_add + 1) (path ~depth:t.depth) in + let* () = + times ~n:t.ncommits ~init:() (fun i () -> + let* tree = Store.get_tree v [] in + if i mod t.gc = 0 then Gc.full_major (); + if i mod t.display = 0 then ( + plot_progress i t.ncommits; + print_stats ~size ~commits:i); + let* tree = + times ~n:t.tree_add ~init:tree (fun n tree -> + Store.Tree.add tree paths.(n) (string_of_int i)) + in + Store.set_tree_exn v ~info [] tree >|= fun () -> + if t.clear then Store.Tree.clear tree) + in + Store.Repo.close r >|= fun () -> Fmt.epr "\n[run done]\n%!" + + let main t config size = + let root = "_build/_bench" in + let config = config ~root in + let size () = size ~root in + let t = { t with root } in + Lwt_main.run (init t config >>= fun () -> run t config size) + + let main_term config size = Term.(const main $ t $ const config $ const size) + + let () = + at_exit (fun () -> + Fmt.epr "tree counters:\n%a\n%!" Store.Tree.dump_counters ()) + + let run ~config ~size = + let info = deprecated_info "Simple benchmark for trees" in + deprecated_exit @@ deprecated_eval (main_term config size, info) +end + +let () = + Metrics.enable_all (); + Metrics_gnuplot.set_reporter () diff --git a/vendors/irmin/src/irmin-test/irmin_bench.mli b/vendors/irmin/src/irmin-test/irmin_bench.mli new file mode 100644 index 0000000000000000000000000000000000000000..ab6fd64410923ad1a82a89ceaa8f2ca04eff4bf5 --- /dev/null +++ b/vendors/irmin/src/irmin-test/irmin_bench.mli @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2019 Etienne Millon + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (S : Irmin.Generic_key.KV with type Schema.Contents.t = string) : sig + val run : + config:(root:string -> Irmin.config) -> size:(root:string -> int) -> unit +end diff --git a/vendors/irmin/src/irmin-test/irmin_test.ml b/vendors/irmin/src/irmin-test/irmin_test.ml new file mode 100644 index 0000000000000000000000000000000000000000..cac12cf3c4db79f49de41c712a54d62ffedea025 --- /dev/null +++ b/vendors/irmin/src/irmin-test/irmin_test.ml @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Common +module Store = Store +module Common = Common +module Node = Node diff --git a/vendors/irmin/src/irmin-test/irmin_test.mli b/vendors/irmin/src/irmin-test/irmin_test.mli new file mode 100644 index 0000000000000000000000000000000000000000..52fa646d486b03c7c91ea00c7a8775966d7dddde --- /dev/null +++ b/vendors/irmin/src/irmin-test/irmin_test.mli @@ -0,0 +1,74 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = Common.S +module type Generic_key = Common.Generic_key + +val reporter : ?prefix:string -> unit -> Logs.reporter + +module Suite : sig + type t + + val create : + name:string -> + ?init:(config:Irmin.config -> unit Lwt.t) -> + ?clean:(config:Irmin.config -> unit Lwt.t) -> + config:Irmin.config -> + store:(module S) -> + ?stats:(unit -> int * int) -> + ?import_supported:bool -> + unit -> + t + + val create_generic_key : + name:string -> + ?init:(config:Irmin.config -> unit Lwt.t) -> + ?clean:(config:Irmin.config -> unit Lwt.t) -> + config:Irmin.config -> + store:(module Generic_key) -> + ?stats:(unit -> int * int) -> + ?import_supported:bool -> + unit -> + t + + val name : t -> string + val config : t -> Irmin.config + val store : t -> (module S) option + val init : t -> config:Irmin.config -> unit Lwt.t + val clean : t -> config:Irmin.config -> unit Lwt.t +end + +val line : string -> unit + +module Schema = Common.Schema + +val store : (module Irmin.Maker) -> (module Irmin.Metadata.S) -> (module S) +val testable : 'a Irmin.Type.t -> 'a Alcotest.testable +val check : 'a Irmin.Type.t -> string -> 'a -> 'a -> unit +val checks : 'a Irmin.Type.t -> string -> 'a list -> 'a list -> unit + +module Store : sig + val run : + string -> + ?slow:bool -> + ?random_seed:int -> + sleep:(float -> unit Lwt.t) -> + misc:unit Alcotest_lwt.test list -> + (Alcotest.speed_level * Suite.t) list -> + unit Lwt.t +end + +module Node = Node diff --git a/vendors/irmin/src/irmin-test/node.ml b/vendors/irmin/src/irmin-test/node.ml new file mode 100644 index 0000000000000000000000000000000000000000..545f01f089bdce8d78d21aa04bee6b474ae659bd --- /dev/null +++ b/vendors/irmin/src/irmin-test/node.ml @@ -0,0 +1,150 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let check pos typ ~expected actual = + let typ = + Alcotest.testable Irmin.Type.(pp_dump typ) Irmin.Type.(unstage (equal typ)) + in + Alcotest.(check ~pos typ) "" expected actual + +module type Map = sig + type t [@@deriving irmin] + type data [@@deriving irmin] + type key := string + + val empty : unit -> t + val is_empty : t -> bool + val length : t -> int + val list : ?offset:int -> ?length:int -> ?cache:bool -> t -> (key * data) list + val find : ?cache:bool -> t -> key -> data option + val add : t -> key -> data -> t + val remove : t -> key -> t + + (* Generators for use by the tests: *) + val random_data : unit -> data +end + +module Suite (Map : Map) = struct + type key = string [@@deriving irmin] + + let random_bindings n = + List.init n (fun i -> (string_of_int i, Map.random_data ())) + + let map_of_bindings kvs = + List.fold_left (fun t (k, v) -> Map.add t k v) (Map.empty ()) kvs + + let test_empty () = + check __POS__ [%typ: bool] ~expected:true Map.(is_empty (empty ())); + check __POS__ [%typ: int] ~expected:0 Map.(length (empty ())); + check __POS__ [%typ: (key * Map.data) list] ~expected:[] + Map.(list (empty ())) + + let test_add () = + let with_binding k v t = Map.add t k v in + let d1 = Map.random_data () and d2 = Map.random_data () in + let a = Map.empty () |> with_binding "1" d1 |> with_binding "2" d2 in + check __POS__ [%typ: int] ~expected:2 (Map.length a) + + let test_remove () = + (* Remove is a no-op on an empty node *) + check __POS__ [%typ: Map.t] ~expected:(Map.empty ()) + Map.(remove (empty ()) "foo") + + let test_find () = + let bindings = random_bindings 256 in + let node = map_of_bindings bindings in + bindings + |> List.iter (fun (k, v) -> + check __POS__ [%typ: Map.data option] ~expected:(Some v) + (Map.find node k)) + + let test_equal () = + let module Map = struct + include Map + + type nonrec t = t [@@deriving irmin ~equal ~to_bin_string ~of_bin_string] + end in + let bindings = random_bindings 256 in + let m = map_of_bindings bindings in + + let m_rev = map_of_bindings (List.rev bindings) in + check __POS__ [%typ: bool] ~expected:true (Map.equal m m_rev); + + let m_subset = map_of_bindings (List.tl bindings) in + check __POS__ [%typ: bool] ~expected:false (Map.equal m m_subset); + + let m_serialised = + m |> Map.to_bin_string |> Map.of_bin_string |> Result.get_ok + in + check __POS__ [%typ: bool] ~expected:true (Map.equal m m_serialised) + + let suite = + [ + ("empty", test_empty); + ("add", test_add); + ("remove", test_remove); + ("find", test_find); + ("equal", test_equal); + ] +end + +module Make (Make_node : Irmin.Node.Generic_key.Maker) : sig + val suite : unit Alcotest.test_case list +end = struct + (* For each [Node] maker, we can instantiate the test suite above twice: once + for regular nodes, and once for portable nodes. *) + + module Schema = Irmin.Schema.KV (Irmin.Contents.String) + module Hash = Schema.Hash + module Key = Irmin.Key.Of_hash (Hash) + module Node = Make_node (Hash) (Schema.Path) (Schema.Metadata) (Key) (Key) + + type key = Key.t [@@deriving irmin] + + module Extras = struct + type data = [ `Node of Key.t | `Contents of Key.t * unit ] + [@@deriving irmin] + + let random_data = + let hash_of_string = Irmin.Type.(unstage (of_bin_string Hash.t)) in + let random_string = + Irmin.Type.(unstage (random (string_of (`Fixed Hash.hash_size)))) + in + fun () -> + match hash_of_string (random_string ()) with + | Error _ -> assert false + | Ok x -> ( + match Random.int 2 with + | 0 -> `Node x + | 1 -> `Contents (x, ()) + | _ -> assert false) + end + + let suite = + let tc (name, f) = Alcotest.test_case name `Quick f in + let module Suite_node = Suite (struct + include Node + include Extras + end) in + let module Suite_node_portable = Suite (struct + include Node.Portable + include Extras + end) in + List.map tc Suite_node.suite + @ List.map + (fun (name, f) -> tc ("Portable." ^ name, f)) + Suite_node_portable.suite +end diff --git a/vendors/irmin/src/irmin-test/rusage.ml b/vendors/irmin/src/irmin-test/rusage.ml new file mode 100644 index 0000000000000000000000000000000000000000..98ac843ba087cbde465d0723a6f2eb7d27a846ee --- /dev/null +++ b/vendors/irmin/src/irmin-test/rusage.ml @@ -0,0 +1,38 @@ +(* + * Copyright (c) 2019-2022 Zach Shipko + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type t = { + utime : float; + stime : float; + maxrss : int64; + ixrss : int64; + idrss : int64; + isrss : int64; + minflt : int64; + majflt : int64; + nswap : int64; + inblock : int64; + oublock : int64; + msgsnd : int64; + msgrcv : int64; + nsignals : int64; + nvcsw : int64; + nivcsw : int64; +} + +type who = SELF | CHILDREN + +external get : who -> t = "unix_getrusage" diff --git a/vendors/irmin/src/irmin-test/rusage_stubs.c b/vendors/irmin/src/irmin-test/rusage_stubs.c new file mode 100644 index 0000000000000000000000000000000000000000..98399707271d668c1161a8e9e4959e06adf364b3 --- /dev/null +++ b/vendors/irmin/src/irmin-test/rusage_stubs.c @@ -0,0 +1,57 @@ +/* Copyright (c) 2019 Zach Shipko + +Permission to use, copy, modify, and/or distribute this software for +any purpose with or without fee is hereby granted, provided that the +above copyright notice and this permission notice appear in all +copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR +PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. */ + +#include +#include +#include +#include + +#include +#include + +#define Nothing Val_int(0) + +CAMLprim value unix_getrusage(value v_who) { + CAMLparam1(v_who); + CAMLlocal1(v_usage); + int who = (Int_val(v_who) == 0) ? RUSAGE_SELF : RUSAGE_CHILDREN; + struct rusage ru; + if (getrusage(who, &ru)) { + caml_invalid_argument("getrusage"); + } + v_usage = caml_alloc(16, 0); + Store_field(v_usage, 0, + caml_copy_double((double)ru.ru_utime.tv_sec + + (double)ru.ru_utime.tv_usec / 1e6)); + Store_field(v_usage, 1, + caml_copy_double((double)ru.ru_stime.tv_sec + + (double)ru.ru_stime.tv_usec / 1e6)); + Store_field(v_usage, 2, caml_copy_int64(ru.ru_maxrss)); + Store_field(v_usage, 3, caml_copy_int64(ru.ru_ixrss)); + Store_field(v_usage, 4, caml_copy_int64(ru.ru_idrss)); + Store_field(v_usage, 5, caml_copy_int64(ru.ru_isrss)); + Store_field(v_usage, 6, caml_copy_int64(ru.ru_minflt)); + Store_field(v_usage, 7, caml_copy_int64(ru.ru_majflt)); + Store_field(v_usage, 8, caml_copy_int64(ru.ru_nswap)); + Store_field(v_usage, 9, caml_copy_int64(ru.ru_inblock)); + Store_field(v_usage, 10, caml_copy_int64(ru.ru_oublock)); + Store_field(v_usage, 11, caml_copy_int64(ru.ru_msgsnd)); + Store_field(v_usage, 12, caml_copy_int64(ru.ru_msgrcv)); + Store_field(v_usage, 13, caml_copy_int64(ru.ru_nsignals)); + Store_field(v_usage, 14, caml_copy_int64(ru.ru_nvcsw)); + Store_field(v_usage, 15, caml_copy_int64(ru.ru_nivcsw)); + CAMLreturn(v_usage); +} diff --git a/vendors/irmin/src/irmin-test/store.ml b/vendors/irmin/src/irmin-test/store.ml new file mode 100644 index 0000000000000000000000000000000000000000..7d2a84d018b33aeb19da137257a9c4e943daf638 --- /dev/null +++ b/vendors/irmin/src/irmin-test/store.ml @@ -0,0 +1,2511 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +let src = Logs.Src.create "test" ~doc:"Irmin tests" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Make (S : Generic_key) = struct + include Common.Make_helpers (S) + module History = Irmin.Commit.History (B.Commit) + + let with_binding k v t = S.Tree.add t k v + let random_value value = random_string value + + let random_path ~label ~path = + let short () = random_ascii_string label in + let rec aux = function 0 -> [] | n -> short () :: aux (n - 1) in + aux path + + let random_node ~label ~path ~value = + (random_path ~label ~path, random_value value) + + let random_nodes ?(label = 8) ?(path = 5) ?(value = 1024) n = + let rec aux acc = function + | 0 -> acc + | n -> aux (random_node ~label ~path ~value :: acc) (n - 1) + in + aux [] n + + let old k () = Lwt.return_ok (Some k) + + let may repo commits = function + | None -> Lwt.return_unit + | Some f -> f repo commits + + let may_get_keys repo keys = function + | None -> Lwt.return_unit + | Some f -> + let* commits = + Lwt_list.map_p + (fun key -> + S.Commit.of_key repo key >|= function + | None -> Alcotest.fail "Cannot read commit hash" + | Some c -> c) + keys + in + f repo commits + + let may_with_branch branches repo hook = + let* heads = + Lwt_list.map_p + (fun branch -> + let+ h = S.Head.find branch in + match h with + | None -> Alcotest.fail "Cannot read head" + | Some head -> head) + branches + in + may repo heads hook + + let contents c = S.Tree.v (`Contents (c, S.Metadata.default)) + + let test_contents x () = + let test repo = + let t = B.Repo.contents_t repo in + let check_key = check B.Contents.Key.t in + let check_val = check (T.option S.contents_t) in + let* kv2 = kv2 ~repo in + let* k2' = with_contents repo (fun t -> B.Contents.add t v2) in + check_key "kv2" kv2 k2'; + let* v2' = B.Contents.find t k2' in + check_val "v2" (Some v2) v2'; + let* k2'' = with_contents repo (fun t -> B.Contents.add t v2) in + check_key "kv2" kv2 k2''; + let* kv1 = kv1 ~repo in + let* k1' = with_contents repo (fun t -> B.Contents.add t v1) in + check_key "kv1" kv1 k1'; + let* k1'' = with_contents repo (fun t -> B.Contents.add t v1) in + check_key "kv1" kv1 k1''; + let* v1' = B.Contents.find t kv1 in + check_val "v1" (Some v1) v1'; + let* v2' = B.Contents.find t kv2 in + check_val "v2" (Some v2) v2'; + B.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = with_contents repo (fun t -> B.Contents.add t v2) in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let get = function None -> Alcotest.fail "get" | Some v -> v + + let test_nodes x () = + let test repo = + let g = g repo and n = n repo in + let* k = + with_contents repo (fun c -> B.Contents.add c "foo") >|= normal + in + let check_hash = check B.Hash.t in + let check_key = check B.Node.Key.t in + let check_val = check [%typ: Graph.value option] in + let check_list = checks [%typ: S.step * B.Node.Val.value] in + let check_node msg v = + let h' = B.Node.Hash.hash v in + let+ key = with_node repo (fun n -> B.Node.add n v) in + check_hash (msg ^ ": hash(v) = add(v)") (B.Node.Key.to_hash key) h' + in + let v = B.Node.Val.empty () in + check_node "empty node" v >>= fun () -> + let v1 = B.Node.Val.add v "x" k in + check_node "node: x" v1 >>= fun () -> + let v2 = B.Node.Val.add v "x" k in + check_node "node: x (bis)" v2 >>= fun () -> + check B.Node.Val.t "add x" v1 v2; + let v0 = B.Node.Val.remove v1 "x" in + check B.Node.Val.t "remove x" v v0; + let v3 = B.Node.Val.add v1 "x" k in + Alcotest.(check bool) "same same" true (v1 == v3); + let u = B.Node.Val.add v3 "y" k in + check_node "node: x+y" v3 >>= fun () -> + let u = B.Node.Val.add u "z" k in + check_node "node: x+y+z" u >>= fun () -> + let check_values u = + check_val "find x" (Some k) (B.Node.Val.find u "x"); + check_val "find y" (Some k) (B.Node.Val.find u "y"); + check_val "find z" (Some k) (B.Node.Val.find u "x"); + check_val "find xx" None (B.Node.Val.find u "xx") + in + check_values u; + let () = + let _w = B.Node.Val.of_list [ ("y", k); ("z", k); ("x", k) ] in + (* XXX: this isn't a valid check. [u] is not concrete, and [w] is. *) + (* check B.Node.Val.t "v" u w; *) + () + in + let all = B.Node.Val.list u in + check_list "list all" [ ("x", k); ("y", k); ("z", k) ] all; + let l = B.Node.Val.list ~length:1 u in + check_list "list length=1" [ ("x", k) ] l; + let l = B.Node.Val.list ~offset:1 u in + check_list "list offset=1" [ ("y", k); ("z", k) ] l; + let l = B.Node.Val.list ~offset:1 ~length:1 u in + check_list "list offset=1 length=1" [ List.nth all 1 ] l; + let u = B.Node.Val.add u "a" k in + check_node "node: x+y+z+a" u >>= fun () -> + let u = B.Node.Val.add u "b" k in + check_node "node: x+y+z+a+b" u >>= fun () -> + let h = B.Node.Hash.hash u in + let* k = with_node repo (fun n -> B.Node.add n u) in + check_hash "hash(v) = add(v)" h (B.Node.Key.to_hash k); + let* w = B.Node.find n k in + check_values (get w); + let* kv1 = kv1 ~repo in + let* k1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + let* k1' = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + check_key "k1.1" k1 k1'; + let* t1 = B.Node.find n k1 in + let k' = B.Node.Val.find (get t1) "x" in + check + (Irmin.Type.option B.Node.Val.value_t) + "find x" + (Some (normal kv1)) + k'; + let* k1'' = with_node repo (fun n -> B.Node.add n (get t1)) in + check_key "k1.2" k1 k1''; + let* k2 = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in + let* k2' = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in + check_key "k2.1" k2 k2'; + let* t2 = B.Node.find n k2 in + let* k2'' = with_node repo (fun n -> B.Node.add n (get t2)) in + check_key "k2.2" k2 k2''; + let* k1''' = Graph.find g k2 [ "b" ] in + check_val "k1.3" (Some (`Node k1)) k1'''; + let* k3 = with_node repo (fun g -> Graph.v g [ ("a", `Node k2) ]) in + let* k3' = with_node repo (fun g -> Graph.v g [ ("a", `Node k2) ]) in + check_key "k3.1" k3 k3'; + let* t3 = B.Node.find n k3 in + let* k3'' = with_node repo (fun n -> B.Node.add n (get t3)) in + check_key "k3.2" k3 k3''; + let* k2'' = Graph.find g k3 [ "a" ] in + check_val "k2.3" (Some (`Node k2)) k2''; + let* k1'''' = Graph.find g k2' [ "b" ] in + check_val "t1.2" (Some (`Node k1)) k1''''; + let* k1''''' = Graph.find g k3 [ "a"; "b" ] in + check_val "t1.3" (Some (`Node k1)) k1'''''; + let* kv11 = Graph.find g k1 [ "x" ] in + check_val "v1.1" (Some (normal kv1)) kv11; + let* kv12 = Graph.find g k2 [ "b"; "x" ] in + check_val "v1.2" (Some (normal kv1)) kv12; + let* kv13 = Graph.find g k3 [ "a"; "b"; "x" ] in + check_val "v1" (Some (normal kv1)) kv13; + let* kv2 = kv2 ~repo in + let* k4 = with_node repo (fun g -> Graph.v g [ ("x", normal kv2) ]) in + let* k5 = + with_node repo (fun g -> Graph.v g [ ("b", `Node k1); ("c", `Node k4) ]) + in + let* k6 = with_node repo (fun g -> Graph.v g [ ("a", `Node k5) ]) in + let* k6' = + with_node repo (fun g -> Graph.add g k3 [ "a"; "c"; "x" ] (normal kv2)) + in + check_key "node k6" k6 k6'; + let* n6' = B.Node.find n k6' in + let* n6 = B.Node.find n k6 in + check T.(option B.Node.Val.t) "node n6" n6 n6'; + let assert_no_duplicates n node = + let names = ref [] in + let+ all = Graph.list g node in + List.iter + (fun (s, _) -> + if List.mem ~equal:String.equal s !names then + Alcotest.failf "%s: duplicate!" n + else names := s :: !names) + all + in + let* n0 = with_node repo (fun g -> Graph.v g []) in + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "b" ] (`Node n0)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "a" ] (`Node n0)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (`Node n0)) in + assert_no_duplicates "1" n3 >>= fun () -> + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "a" ] (`Node n0)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "b" ] (`Node n0)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (`Node n0)) in + assert_no_duplicates "2" n3 >>= fun () -> + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "b" ] (normal kv1)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "a" ] (normal kv1)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (normal kv1)) in + assert_no_duplicates "3" n3 >>= fun () -> + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "a" ] (normal kv1)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "b" ] (normal kv1)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "b" ] (normal kv1)) in + assert_no_duplicates "4" n3 >>= fun () -> + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let* n0 = with_node repo (fun g -> Graph.v g []) in + let* _ = + with_node repo (fun g -> Graph.add g n0 [ "b" ] (`Node n0)) + in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let test_commits x () = + let test repo = + let info date = + let message = Fmt.str "Test commit: %d" date in + S.Info.v ~author:"test" ~message (Int64.of_int date) + in + let* kv1 = kv1 ~repo in + let h = h repo and c = B.Repo.commit_t repo in + let check_val = check (T.option B.Commit.Val.t) in + let check_key = check B.Commit.Key.t in + let check_keys = checks B.Commit.Key.t in + (* t3 -a-> t2 -b-> t1 -x-> (v1) *) + let* kt1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + let* kt2 = with_node repo (fun g -> Graph.v g [ ("a", `Node kt1) ]) in + let* kt3 = with_node repo (fun g -> Graph.v g [ ("b", `Node kt2) ]) in + (* r1 : t2 *) + let with_info n fn = with_commit repo (fun h -> fn h ~info:(info n)) in + let* kr1, _ = with_info 3 (History.v ~node:kt2 ~parents:[]) in + let* kr1', _ = with_info 3 (History.v ~node:kt2 ~parents:[]) in + let* t1 = B.Commit.find c kr1 in + let* t1' = B.Commit.find c kr1' in + check_val "t1" t1 t1'; + check_key "kr1" kr1 kr1'; + + (* r1 -> r2 : t3 *) + let* kr2, _ = with_info 4 (History.v ~node:kt3 ~parents:[ kr1 ]) in + let* kr2', _ = with_info 4 (History.v ~node:kt3 ~parents:[ kr1 ]) in + check_key "kr2" kr2 kr2'; + let* kr1s = History.closure h ~min:[] ~max:[ kr1 ] in + check_keys "g1" [ kr1 ] kr1s; + let* kr2s = History.closure h ~min:[] ~max:[ kr2 ] in + check_keys "g2" [ kr1; kr2 ] kr2s; + let* () = + S.Commit.of_key repo kr1 >|= function + | None -> Alcotest.fail "Cannot read commit hash" + | Some c -> + Alcotest.(check string) + "author" "test" + (S.Info.author (S.Commit.info c)) + in + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = with_info 3 (History.v ~node:kt1 ~parents:[]) in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let test_closure x () = + let test repo = + let info date = + let message = Fmt.str "Test commit: %d" date in + S.Info.v ~author:"test" ~message (Int64.of_int date) + in + let check_keys = checks B.Commit.Key.t in + let equal_key = Irmin.Type.(unstage (equal B.Commit.Key.t)) in + let h = h repo in + let initialise_nodes = + Lwt_list.map_p + (fun i -> + let* kv = + with_contents repo (fun t -> B.Contents.add t (string_of_int i)) + in + with_node repo (fun g -> Graph.v g [ (string_of_int i, normal kv) ])) + [ 0; 1; 2; 3; 4; 5; 6; 7; 8 ] + in + let with_info n fn = with_commit repo (fun h -> fn h ~info:(info n)) in + let initialise_graph nodes = + match nodes with + | [] -> assert false + | node :: rest -> + let* kr0, _ = with_info 0 (History.v ~node ~parents:[]) in + let commits = Array.make 9 kr0 in + let commit ~node ~parents i = + let+ kr1, _ = with_info i (History.v ~node ~parents) in + commits.(i) <- kr1; + i + 1 + in + let+ _ = + Lwt_list.fold_left_s + (fun i node -> + match i with + | 1 -> commit ~node ~parents:[ commits.(0) ] 1 + | 2 -> commit ~node ~parents:[] 2 + | 3 -> commit ~node ~parents:[ commits.(1) ] 3 + | 4 -> commit ~node ~parents:[ commits.(1); commits.(2) ] 4 + | 5 -> commit ~node ~parents:[ commits.(3); commits.(4) ] 5 + | 6 -> commit ~node ~parents:[ commits.(4) ] 6 + | 7 -> commit ~node ~parents:[] 7 + | 8 -> commit ~node ~parents:[ commits.(7) ] 8 + | _ -> assert false) + 1 rest + in + commits + in + (* initialise_graph creates the following graph of commits: + 0 <- 1 <- 3 <- 5 and 7 <- 8 + \ / + 2 <-- 4 <- 6 *) + let* commits = initialise_nodes >>= initialise_graph in + let* krs = History.closure h ~min:[ commits.(1) ] ~max:[ commits.(5) ] in + check_keys "commits between 1 and 5" + [ commits.(1); commits.(2); commits.(3); commits.(4); commits.(5) ] + krs; + let* krs = History.closure h ~min:[] ~max:[ commits.(5) ] in + check_keys "all commits under 5" + [ + commits.(0); + commits.(1); + commits.(2); + commits.(3); + commits.(4); + commits.(5); + ] + krs; + let* krs = + History.closure h + ~min:[ commits.(1); commits.(2) ] + ~max:[ commits.(5); commits.(6) ] + in + check_keys "disconnected max and min returns a connected graph" + [ + commits.(1); + commits.(2); + commits.(3); + commits.(4); + commits.(5); + commits.(6); + ] + krs; + let* krs = + History.closure h + ~min:[ commits.(1); commits.(7) ] + ~max:[ commits.(4); commits.(8) ] + in + check_keys "disconnected min and max returns a disconnected graph" + [ commits.(1); commits.(2); commits.(7); commits.(4); commits.(8) ] + krs; + let* () = + History.closure h ~min:[ commits.(7) ] ~max:[] >|= function + | [] -> () + | _ -> Alcotest.fail "expected empty list" + in + let* () = + let+ ls = History.closure h ~min:[ commits.(7) ] ~max:[ commits.(6) ] in + if List.mem ~equal:equal_key commits.(7) ls then + Alcotest.fail "disconnected node should not be in closure" + in + let* krs = + History.closure h ~min:[ commits.(4) ] ~max:[ commits.(4); commits.(6) ] + in + check_keys "min and max have the same commit" + [ commits.(6); commits.(4) ] + krs; + let* () = + let+ ls = + History.closure h + ~min:[ commits.(4); commits.(0) ] + ~max:[ commits.(4); commits.(6) ] + in + if List.mem ~equal:equal_key commits.(0) ls then + Alcotest.fail "disconnected node should not be in closure" + in + S.Repo.close repo + in + run x test + + let test_branches ?hook x () = + let test repo = + let check_keys = checks S.Branch.t in + let check_val = check (T.option @@ S.commit_t repo) in + let* kv1 = r1 ~repo in + let* kv2 = r2 ~repo in + line "pre-update"; + S.Branch.set repo b1 kv1 >>= fun () -> + may repo [ kv2 ] hook >>= fun () -> + line "post-update"; + let* k1' = S.Branch.find repo b1 in + check_val "r1" (Some kv1) k1'; + S.Branch.set repo b2 kv2 >>= fun () -> + let* k2' = S.Branch.find repo b2 in + check_val "r2" (Some kv2) k2'; + S.Branch.set repo b1 kv2 >>= fun () -> + let* k2'' = S.Branch.find repo b1 in + check_val "r1-after-update" (Some kv2) k2''; + let* bs = S.Branch.list repo in + check_keys "list" [ b1; b2 ] bs; + S.Branch.remove repo b1 >>= fun () -> + let* empty = S.Branch.find repo b1 in + check_val "empty" None empty; + let* b2' = S.Branch.list repo in + check_keys "all-after-remove" [ b2 ] b2'; + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = S.Branch.set repo b1 kv1 in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let test_tree_hashes x () = + let test repo = + let node bindings = + with_node repo (fun g -> + let* empty = Graph.empty g in + Lwt_list.fold_left_s + (fun t (k, v) -> + let* v = with_contents repo (fun t -> B.Contents.add t v) in + Graph.add g t k (`Contents (v, S.Metadata.default))) + empty bindings) + in + let tree bindings = + Lwt_list.fold_left_s + (fun t (k, v) -> S.Tree.add t k v) + (S.Tree.empty ()) bindings + in + let check_hash msg bindings = + let* node = node bindings in + let+ tree = tree bindings in + check B.Hash.t msg (B.Node.Key.to_hash node) (S.Tree.hash tree) + in + check_hash "empty" [] >>= fun () -> + let bindings1 = [ ([ "a" ], "x"); ([ "b" ], "y") ] in + check_hash "1 level" bindings1 >>= fun () -> + let bindings2 = [ ([ "a"; "b" ], "x"); ([ "a"; "c" ], "y") ] in + check_hash "2 levels" bindings2 >>= fun () -> S.Repo.close repo + in + run x test + + let test_simple_merges ?hook x () = + (* simple merges *) + let check_merge () = + let ok = Irmin.Merge.ok in + let dt = [%typ: int64 option] in + let dx = [%typ: (string * int64) list] in + let merge_skip ~old:_ _ _ = ok None in + let merge_left ~old:_ x _ = ok x in + let merge_right ~old:_ _ y = ok y in + let merge_default = Irmin.Merge.default dt in + let merge = function + | "left" -> Irmin.Merge.v dt merge_left + | "right" -> Irmin.Merge.v dt merge_right + | "skip" -> Irmin.Merge.v dt merge_skip + | _ -> merge_default + in + let merge_x = Irmin.Merge.alist T.string T.int64 merge in + let old () = ok (Some [ ("left", 1L); ("foo", 2L) ]) in + let x = [ ("left", 2L); ("right", 0L) ] in + let y = [ ("left", 1L); ("bar", 3L); ("skip", 0L) ] in + let m = [ ("left", 2L); ("bar", 3L) ] in + Irmin.Merge.(f merge_x) ~old x y >>= function + | Error (`Conflict c) -> Alcotest.failf "conflict %s" c + | Ok m' -> + check dx "compound merge" m m'; + Lwt.return_unit + in + let test repo = + check_merge () >>= fun () -> + let* kv1 = kv1 ~repo in + let* kv2 = kv2 ~repo in + let result = + T.(result (option B.Contents.Key.t) Irmin.Merge.conflict_t) + in + (* merge contents *) + let* kv1' = + with_contents repo (fun v -> + Irmin.Merge.f (B.Contents.merge v) ~old:(old (Some kv1)) (Some kv1) + (Some kv1)) + in + check result "merge kv1" (Ok (Some kv1)) kv1'; + let* kv2' = + with_contents repo (fun v -> + Irmin.Merge.f (B.Contents.merge v) ~old:(old (Some kv1)) (Some kv1) + (Some kv2)) + in + check result "merge kv2" (Ok (Some kv2)) kv2'; + + (* merge nodes *) + let g = g repo in + (* The empty node *) + let* k0 = with_node repo (fun g -> Graph.v g []) in + (* Create the node t1 -x-> (v1) *) + let* k1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + (* Create the node t2 -b-> t1 -x-> (v1) *) + let* k2 = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in + (* Create the node t3 -c-> t1 -x-> (v1) *) + let* k3 = with_node repo (fun g -> Graph.v g [ ("c", `Node k1) ]) in + (* Should create the node: + t4 -b-> t1 -x-> (v1) + \c/ *) + let* k4 = + with_node repo (fun g -> + Irmin.Merge.(f @@ B.Node.merge g) + ~old:(old (Some k0)) (Some k2) (Some k3)) + in + let* k4 = merge_exn "k4" k4 in + let k4 = match k4 with Some k -> k | None -> failwith "k4" in + let _ = k4 in + let succ_t = [%typ: string * Graph.value] in + let* succ = Graph.list g k4 in + checks succ_t "k4" [ ("b", `Node k1); ("c", `Node k1) ] succ; + let info date = + let i = Int64.of_int date in + S.Info.v ~author:"test" ~message:"Test commit" i + in + let c = B.Repo.commit_t repo in + let with_info n fn = with_commit repo (fun h -> fn h ~info:(info n)) in + let* kr0, _ = with_info 0 (History.v ~node:k0 ~parents:[]) in + let* kr1, _ = with_info 1 (History.v ~node:k2 ~parents:[ kr0 ]) in + let* kr2, _ = with_info 2 (History.v ~node:k3 ~parents:[ kr0 ]) in + may_get_keys repo [ kr1; kr2 ] hook >>= fun () -> + let* kr3 = + with_info 3 (fun h ~info -> + Irmin.Merge.f + (History.merge h ~info:(fun () -> info)) + ~old:(old kr0) kr1 kr2) + in + let* kr3 = merge_exn "kr3" kr3 in + may_get_keys repo [ kr3 ] hook >>= fun () -> + let* kr3_key' = + with_info 4 (fun h ~info -> + Irmin.Merge.f + (History.merge h ~info:(fun () -> info)) + ~old:(old kr2) kr2 kr3) + in + let* kr3_key' = merge_exn "kr3_key'" kr3_key' in + let check_key = check B.Commit.Key.t in + check_key "kr3 id with immediate parent'" kr3 kr3_key'; + let* kr3_key = + with_info 5 (fun h ~info -> + Irmin.Merge.f + (History.merge h ~info:(fun () -> info)) + ~old:(old kr0) kr0 kr3) + in + let* kr3_key = merge_exn "kr3_key" kr3_key in + check_key "kr3 key with old parent" kr3 kr3_key; + let* kr3', _ = with_info 3 @@ History.v ~node:k4 ~parents:[ kr1; kr2 ] in + let* r3 = B.Commit.find c kr3 in + let* r3' = B.Commit.find c kr3' in + check T.(option B.Commit.Val.t) "r3" r3 r3'; + check_key "kr3" kr3 kr3'; + B.Repo.close repo + in + run x test + + let test_history ?hook x () = + let test repo = + let info date = + let i = Int64.of_int date in + S.Info.v ~author:"test" ~message:"Test commit" i + in + let assert_lcas_err msg err l2 = + let err_str = function + | `Too_many_lcas -> "Too_many_lcas" + | `Max_depth_reached -> "Max_depth_reached" + in + let pp_commits = Fmt.Dump.(list S.Commit.pp_hash) in + let l2 = + match l2 with + | Ok x -> Alcotest.failf "%s: %a" msg pp_commits x + | Error e -> err_str e + in + Alcotest.(check string) msg (err_str err) l2 + in + let assert_lcas msg l1 l2 = + let l2 = + match l2 with + | Ok x -> x + | Error `Too_many_lcas -> Alcotest.failf "%s: Too many LCAs" msg + | Error `Max_depth_reached -> + Alcotest.failf "%s: max depth reached" msg + in + checks (S.commit_t repo) msg l1 l2 + in + let assert_lcas msg ~max_depth n a b expected = + let* a = S.of_commit a in + let* b = S.of_commit b in + let* lcas = S.lcas ~max_depth ~n a b in + assert_lcas msg expected lcas; + let* lcas = S.lcas ~max_depth:(max_depth - 1) ~n a b in + let msg = Printf.sprintf "%s [max-depth=%d]" msg (max_depth - 1) in + assert_lcas_err msg `Max_depth_reached lcas; + Lwt.return_unit + in + let assert_last_modified msg ?depth ~n t key expected = + let+ last = S.last_modified ?depth ~n t key in + S.repo t |> fun repo -> + let msg = Printf.sprintf "%s [n=%d]" msg n in + checks (S.commit_t repo) msg expected last + in + let assert_history_empty msg c expected = + let* t = S.of_commit c in + S.history t + >|= S.History.is_empty + >|= Alcotest.(check bool) msg expected + in + let tree = S.Tree.empty () in + let k0 = random_path ~label:8 ~path:5 in + let k1 = random_path ~label:8 ~path:4 in + let k2 = random_path ~label:8 ~path:6 in + + (* test that we don't compute too many lcas + + 0(k0, k1) -> 1(k1) -> 2(k0) -> 3(k1, k0) -> 4(k1) + *) + let* tree = S.Tree.add tree k0 (random_value 1024) in + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c0 = S.Commit.v repo ~info:(info 0) ~parents:[] tree in + may repo [ c0 ] hook >>= fun () -> + assert_history_empty "nonempty 1 commit" c0 false >>= fun () -> + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c1 = + S.Commit.v repo ~info:(info 1) ~parents:[ S.Commit.key c0 ] tree + in + assert_history_empty "nonempty 2 commits" c0 false >>= fun () -> + let* tree = S.Tree.add tree k0 (random_value 1024) in + let* c2 = + S.Commit.v repo ~info:(info 2) ~parents:[ S.Commit.key c1 ] tree + in + let* tree = S.Tree.add tree k0 (random_value 1024) in + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c3 = + S.Commit.v repo ~info:(info 3) ~parents:[ S.Commit.key c2 ] tree + in + may repo [ c3 ] hook >>= fun () -> + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c4 = + S.Commit.v repo ~info:(info 4) ~parents:[ S.Commit.key c3 ] tree + in + assert_lcas "line lcas 1" ~max_depth:0 3 c3 c4 [ c3 ] >>= fun () -> + assert_lcas "line lcas 2" ~max_depth:1 3 c2 c4 [ c2 ] >>= fun () -> + assert_lcas "line lcas 3" ~max_depth:2 3 c1 c4 [ c1 ] >>= fun () -> + let* store = S.of_commit c4 in + let* () = + assert_last_modified "line last_modified 1" ~n:1 store k0 [ c3 ] + in + let* () = + assert_last_modified "line last_modified 2" ~n:2 store k0 [ c2; c3 ] + in + let* () = + assert_last_modified "line last_modified 3" ~n:3 store k0 [ c0; c2; c3 ] + in + let* () = + assert_last_modified "line last_modified 4" ~depth:1 ~n:3 store k0 + [ c3 ] + in + assert_last_modified "line last_modified 5" ~n:1 store k2 [] >>= fun () -> + let* () = + assert_last_modified "line last_modified 5" ~depth:0 ~n:2 store k0 [] + in + (* test for multiple lca + + 4(k1) -> 10 (k2) ---> 11(k0, k2) --> 13(k1) --> 15(k1, k2) + | \_______________________/____ + | _____________________/ \ + | / \ + \---> 12 (k0, k1) --> 14 (k2) --> 16 (k2) --> 17 (k0) + *) + let* tree = S.Tree.add tree k2 (random_value 1024) in + let* c10 = + S.Commit.v repo ~info:(info 10) ~parents:[ S.Commit.key c4 ] tree + in + let* tree_up = S.Tree.add tree k0 (random_value 1024) in + let* tree_up = S.Tree.add tree_up k2 (random_value 1024) in + let* c11 = + S.Commit.v repo ~info:(info 11) ~parents:[ S.Commit.key c10 ] tree_up + in + let* tree_down = S.Tree.add tree k0 (random_value 1024) in + let* tree_12 = S.Tree.add tree_down k1 (random_value 1024) in + let* c12 = + S.Commit.v repo ~info:(info 12) ~parents:[ S.Commit.key c10 ] tree_12 + in + let* tree_up = S.Tree.add tree_up k1 (random_value 1024) in + let* c13 = + S.Commit.v repo ~info:(info 13) ~parents:[ S.Commit.key c11 ] tree_up + in + let* tree_down = S.Tree.add tree_12 k2 (random_value 1024) in + let* c14 = + S.Commit.v repo ~info:(info 14) ~parents:[ S.Commit.key c12 ] tree_down + in + let* tree_up = S.Tree.add tree_12 k1 (random_value 1024) in + let* tree_up = S.Tree.add tree_up k2 (random_value 1024) in + let* c15 = + S.Commit.v repo ~info:(info 15) + ~parents:[ S.Commit.key c12; S.Commit.key c13 ] + tree_up + in + let* tree_down = S.Tree.add tree_down k2 (random_value 1024) in + let* c16 = + S.Commit.v repo ~info:(info 16) ~parents:[ S.Commit.key c14 ] tree_down + in + let* tree_down = S.Tree.add tree_down k0 (random_value 1024) in + let* c17 = + S.Commit.v repo ~info:(info 17) + ~parents:[ S.Commit.key c11; S.Commit.key c16 ] + tree_down + in + assert_lcas "x lcas 0" ~max_depth:0 5 c10 c10 [ c10 ] >>= fun () -> + assert_lcas "x lcas 1" ~max_depth:0 5 c14 c14 [ c14 ] >>= fun () -> + assert_lcas "x lcas 2" ~max_depth:0 5 c10 c11 [ c10 ] >>= fun () -> + assert_lcas "x lcas 3" ~max_depth:1 5 c12 c16 [ c12 ] >>= fun () -> + assert_lcas "x lcas 4" ~max_depth:1 5 c10 c13 [ c10 ] >>= fun () -> + assert_lcas "x lcas 5" ~max_depth:2 5 c13 c14 [ c10 ] >>= fun () -> + assert_lcas "x lcas 6" ~max_depth:3 5 c15 c16 [ c12 ] >>= fun () -> + assert_lcas "x lcas 7" ~max_depth:3 5 c15 c17 [ c11; c12 ] >>= fun () -> + let* store = S.of_commit c17 in + let* () = + assert_last_modified "x last_modified 1" ~n:3 store k0 [ c11; c12; c17 ] + in + let* () = + assert_last_modified "x last_modified 2" ~n:1 store k2 [ c16 ] + in + let* () = + assert_last_modified "x last_modified 3" ~n:2 store k1 [ c4; c12 ] + in + let* () = + assert_last_modified "x last_modified 4" ~depth:3 ~n:5 store k1 + [ c4; c12 ] + in + let* () = + assert_last_modified "x last_modified 5" ~depth:2 ~n:3 store k0 + [ c11; c17 ] + in + (* lcas on non transitive reduced graphs + + /->16 + | + 4->10->11->12->13->14->15 + | \--|--/ + \-----------/ + *) + let* c10 = + S.Commit.v repo ~info:(info 10) ~parents:[ S.Commit.key c4 ] tree + in + let* c11 = + S.Commit.v repo ~info:(info 11) ~parents:[ S.Commit.key c10 ] tree + in + let* c12 = + S.Commit.v repo ~info:(info 12) ~parents:[ S.Commit.key c11 ] tree + in + let* c13 = + S.Commit.v repo ~info:(info 13) ~parents:[ S.Commit.key c12 ] tree + in + let* c14 = + S.Commit.v repo ~info:(info 14) + ~parents:[ S.Commit.key c11; S.Commit.key c13 ] + tree + in + let* c15 = + S.Commit.v repo ~info:(info 15) + ~parents:[ S.Commit.key c13; S.Commit.key c14 ] + tree + in + let* c16 = + S.Commit.v repo ~info:(info 16) ~parents:[ S.Commit.key c11 ] tree + in + assert_lcas "weird lcas 1" ~max_depth:0 3 c14 c15 [ c14 ] >>= fun () -> + assert_lcas "weird lcas 2" ~max_depth:0 3 c13 c15 [ c13 ] >>= fun () -> + assert_lcas "weird lcas 3" ~max_depth:1 3 c12 c15 [ c12 ] >>= fun () -> + assert_lcas "weird lcas 4" ~max_depth:1 3 c11 c15 [ c11 ] >>= fun () -> + assert_lcas "weird lcas 4" ~max_depth:3 3 c15 c16 [ c11 ] >>= fun () -> + (* fast-forward *) + let ff = testable Irmin.Type.(result unit S.ff_error_t) in + let* t12 = S.of_commit c12 in + let* b1 = S.Head.fast_forward t12 c16 in + Alcotest.(check ff) "ff 1.1" (Error `Rejected) b1; + let* k12' = S.Head.get t12 in + check (S.commit_t repo) "ff 1.2" c12 k12'; + let* b2 = S.Head.fast_forward t12 ~n:1 c14 in + Alcotest.(check ff) "ff 2.1" (Error `Rejected) b2; + let* k12'' = S.Head.get t12 in + check (S.commit_t repo) "ff 2.2" c12 k12''; + let* b3 = S.Head.fast_forward t12 c14 in + Alcotest.(check ff) "ff 2.2" (Ok ()) b3; + let* c14' = S.Head.get t12 in + check (S.commit_t repo) "ff 2.3" c14 c14'; + B.Repo.close repo + in + run x test + + let test_empty ?hook x () = + let test repo = + let* t = S.empty repo in + let* h = S.Head.find t in + check T.(option @@ S.commit_t repo) "empty" None h; + let* r1 = r1 ~repo in + may repo [ r1 ] hook >>= fun () -> + S.set_exn t ~info:S.Info.none [ "b"; "x" ] v1 >>= fun () -> + let* h = S.Head.find t in + check T.(option @@ S.commit_t repo) "not empty" (Some r1) h; + B.Repo.close repo + in + run x test + + let test_slice ?hook x () = + let test repo = + let* t = S.main repo in + let a = "" in + let b = "haha" in + S.set_exn t ~info:(infof "slice") [ "x"; "a" ] a >>= fun () -> + S.set_exn t ~info:(infof "slice") [ "x"; "b" ] b >>= fun () -> + may_with_branch [ t ] repo hook >>= fun () -> + let* slice = S.Repo.export repo in + let str = T.to_json_string B.Slice.t slice in + let slice' = + match T.decode_json B.Slice.t (Jsonm.decoder (`String str)) with + | Ok t -> t + | Error (`Msg e) -> Alcotest.failf "decoding error: %s" e + in + check B.Slice.t "slices" slice slice'; + B.Repo.close repo + in + run x test + + let test_backend_nodes ?hook x () = + let test repo = + let check_val = check [%typ: S.contents option] in + let vx = "VX" in + let vy = "VY" in + let* t = S.main repo in + S.set_exn t ~info:(infof "add x/y/z") [ "x"; "y"; "z" ] vx >>= fun () -> + let* tree = S.get_tree t [ "x" ] in + S.set_tree_exn t ~info:(infof "update") [ "u" ] tree >>= fun () -> + let* vx' = S.find t [ "u"; "y"; "z" ] in + check_val "vx" (Some vx) vx'; + let* tree1 = S.get_tree t [ "u" ] in + S.set_exn t ~info:(infof "add u/x/y") [ "u"; "x"; "y" ] vy >>= fun () -> + may_with_branch [ t ] repo hook >>= fun () -> + let* tree2 = S.get_tree t [ "u" ] in + let* tree3 = S.Tree.add tree [ "x"; "z" ] vx in + let* v' = + Irmin.Merge.f S.Tree.merge ~old:(Irmin.Merge.promise tree1) tree2 tree3 + >>= merge_exn "tree" + in + S.set_tree_exn t ~info:(infof "merge") [ "u" ] v' >>= fun () -> + let* vy' = S.find t [ "u"; "x"; "y" ] in + check_val "vy after merge" (Some vy) vy'; + let* vx' = S.find t [ "u"; "x"; "z" ] in + check_val "vx after merge" (Some vx) vx'; + B.Repo.close repo + in + run x test + + let test_stores x () = + let test repo = + let check_val = check [%typ: S.contents option] in + let check_list = checks [%typ: S.Path.step * S.tree] in + let* t = S.main repo in + S.set_exn t ~info:(infof "init") [ "a"; "b" ] v1 >>= fun () -> + let* b0 = S.mem t [ "a"; "b" ] in + Alcotest.(check bool) "mem0" true b0; + let* t = S.clone ~src:t ~dst:"test" in + let* b1 = S.mem t [ "a"; "b" ] in + Alcotest.(check bool) "mem1" true b1; + let* b2 = S.mem t [ "a" ] in + Alcotest.(check bool) "mem2" false b2; + let* v1' = S.find t [ "a"; "b" ] in + check_val "v1.1" (Some v1) v1'; + let* r1 = S.Head.get t in + let* t = S.clone ~src:t ~dst:"test" in + S.set_exn t ~info:(infof "update") [ "a"; "c" ] v2 >>= fun () -> + let* b1 = S.mem t [ "a"; "b" ] in + Alcotest.(check bool) "mem3" true b1; + let* b2 = S.mem t [ "a" ] in + Alcotest.(check bool) "mem4" false b2; + let* v1' = S.find t [ "a"; "b" ] in + check_val "v1.1" (Some v1) v1'; + let* b1 = S.mem t [ "a"; "c" ] in + Alcotest.(check bool) "mem5" true b1; + let* v2' = S.find t [ "a"; "c" ] in + check_val "v1.1" (Some v2) v2'; + S.remove_exn t ~info:(infof "remove") [ "a"; "b" ] >>= fun () -> + let* v1'' = S.find t [ "a"; "b" ] in + check_val "v1.2" None v1''; + S.Head.set t r1 >>= fun () -> + let* v1'' = S.find t [ "a"; "b" ] in + check_val "v1.3" (Some v1) v1''; + let* ks = S.list t [ "a" ] in + check_list "path" [ ("b", contents v1) ] ks; + let* () = + S.set_exn t ~info:(infof "update2") [ "a"; long_random_ascii_string ] v1 + in + S.remove_exn t ~info:(infof "remove rec") [ "a" ] >>= fun () -> + let* dirs = S.list t [] in + check_list "remove rec" [] dirs; + let* () = + Lwt.catch + (fun () -> + S.set_exn t ~info:(infof "update root") [] v1 >>= fun () -> + Alcotest.fail "update root") + (function + | Invalid_argument _ -> Lwt.return_unit + | e -> Alcotest.fail ("update root: " ^ Printexc.to_string e)) + in + let* none = S.find t [] in + check_val "read root" none None; + S.set_exn t ~info:(infof "update") [ "a" ] v1 >>= fun () -> + S.remove_exn t ~info:(infof "remove rec --all") [] >>= fun () -> + let* dirs = S.list t [] in + check_list "remove rec root" [] dirs; + let a = "ok" in + let b = "maybe?" in + S.set_exn t ~info:(infof "fst one") [ "fst" ] a >>= fun () -> + S.set_exn t ~info:(infof "snd one") [ "fst"; "snd" ] b >>= fun () -> + let* fst = S.find t [ "fst" ] in + check_val "data model 1" None fst; + let* snd = S.find t [ "fst"; "snd" ] in + check_val "data model 2" (Some b) snd; + S.set_exn t ~info:(infof "fst one") [ "fst" ] a >>= fun () -> + let* fst = S.find t [ "fst" ] in + check_val "data model 3" (Some a) fst; + let* snd = S.find t [ "fst"; "snd" ] in + check_val "data model 4" None snd; + let tagx = "x" in + let tagy = "y" in + let xy = [ "x"; "y" ] in + let vx = "VX" in + let* tx = S.of_branch repo tagx in + S.Branch.remove repo tagx >>= fun () -> + S.Branch.remove repo tagy >>= fun () -> + S.set_exn tx ~info:(infof "update") xy vx >>= fun () -> + let* ty = S.clone ~src:tx ~dst:tagy in + let* vx' = S.find ty xy in + check_val "update tag" (Some vx) vx'; + S.status tx |> fun tagx' -> + S.status ty |> fun tagy' -> + check (S.Status.t repo) "tagx" (`Branch tagx) tagx'; + check (S.Status.t repo) "tagy" (`Branch tagy) tagy'; + let* t = S.main repo in + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = S.set_exn t ~info:(infof "add after close") [ "a" ] "bar" in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let stats_t = Alcotest.testable (Irmin.Type.pp_dump S.Tree.stats_t) ( = ) + + let empty_stats = + { S.Tree.nodes = 0; leafs = 0; skips = 0; depth = 0; width = 0 } + + let inspect = + Alcotest.testable + (fun ppf -> function + | `Contents -> Fmt.string ppf "contents" + | `Node `Key -> Fmt.string ppf "key" + | `Node `Map -> Fmt.string ppf "map" + | `Node `Value -> Fmt.string ppf "value" + | `Node `Portable_dirty -> Fmt.string ppf "portable_dirty" + | `Node `Pruned -> Fmt.string ppf "pruned") + ( = ) + + let test_tree_caches x () = + let test repo = + let info = S.Info.none in + let* t1 = S.main repo in + S.set_exn t1 ~info [ "a"; "b" ] "foo" >>= fun () -> + (* Testing cache *) + S.Tree.reset_counters (); + let* v = S.get_tree t1 [] in + Alcotest.(check inspect) "inspect" (`Node `Key) (S.Tree.inspect v); + let* v = S.Tree.add v [ "foo" ] "foo" in + Alcotest.(check inspect) "inspect:0" (`Node `Value) (S.Tree.inspect v); + Alcotest.(check int) "val-v:0" 0 (S.Tree.counters ()).node_val_v; + let* v = S.Tree.add v [ "bar"; "foo" ] "bar" in + Alcotest.(check inspect) "inspect:1" (`Node `Value) (S.Tree.inspect v); + Alcotest.(check int) "val-v:1" 0 (S.Tree.counters ()).node_val_v; + Alcotest.(check int) "val-list:1" 0 (S.Tree.counters ()).node_val_list; + let _ = S.Tree.hash v in + Alcotest.(check inspect) "inspect:2" (`Node `Value) (S.Tree.inspect v); + Alcotest.(check int) "val-v:2" 1 (S.Tree.counters ()).node_val_v; + Alcotest.(check int) "val-list:2" 0 (S.Tree.counters ()).node_val_list; + S.set_tree_exn t1 ~info [] v >>= fun () -> + Alcotest.(check inspect) "inspect:3" (`Node `Key) (S.Tree.inspect v); + Alcotest.(check int) "val-v:3" 2 (S.Tree.counters ()).node_val_v; + Alcotest.(check int) "val-list:3" 0 (S.Tree.counters ()).node_val_list; + B.Repo.close repo + in + run x test + + let pp_depth = Irmin.Type.pp S.Tree.depth_t + let pp_key = Irmin.Type.pp S.Path.t + let contents_t = T.pair S.contents_t S.metadata_t + let diff_t = T.(pair S.path_t (Irmin.Diff.t contents_t)) + let check_diffs = checks diff_t + let check_ls = checks T.(pair S.step_t S.tree_t) + + let test_trees x () = + let test repo = + let* t = S.main repo in + let nodes = random_nodes 100 in + let foo1 = random_value 10 in + let foo2 = random_value 10 in + let* v1 = + S.Tree.singleton [ "foo"; "bar"; "toto" ] foo2 + |> with_binding [ "foo"; "toto" ] foo1 + in + S.Tree.clear v1; + let* () = + let dont_skip k = + Alcotest.failf "should not have skipped: '%a'" pp_key k + in + S.Tree.fold ~depth:(`Eq 1) ~force:(`False dont_skip) v1 () + in + let* () = + S.Tree.fold ~depth:(`Eq 1) ~force:`True (S.Tree.empty ()) () + ~contents:(fun k _ -> + assert (List.length k = 1); + Alcotest.fail "contents") + ~node:(fun k _ -> + assert (List.length k = 1); + Alcotest.fail "node") + in + let fold depth ecs ens = + let* cs, ns = + S.Tree.fold v1 ?depth ~force:`True ~cache:false + ~contents:(fun path _ (cs, ns) -> Lwt.return (path :: cs, ns)) + ~node:(fun path _ (cs, ns) -> Lwt.return (cs, path :: ns)) + ([], []) + in + let paths = Alcotest.slist (testable S.Path.t) compare in + Alcotest.(check paths) + (Fmt.str "contents depth=%a" Fmt.(Dump.option pp_depth) depth) + ecs cs; + Alcotest.(check paths) + (Fmt.str "nodes depth=%a" Fmt.(Dump.option pp_depth) depth) + ens ns; + Lwt.return () + in + let* () = + fold None + [ [ "foo"; "bar"; "toto" ]; [ "foo"; "toto" ] ] + [ []; [ "foo" ]; [ "foo"; "bar" ] ] + in + fold (Some (`Eq 0)) [] [ [] ] >>= fun () -> + fold (Some (`Eq 1)) [] [ [ "foo" ] ] >>= fun () -> + let* () = + fold (Some (`Eq 2)) [ [ "foo"; "toto" ] ] [ [ "foo"; "bar" ] ] + in + fold (Some (`Lt 2)) [] [ []; [ "foo" ] ] >>= fun () -> + let* () = + fold + (Some (`Le 2)) + [ [ "foo"; "toto" ] ] + [ []; [ "foo" ]; [ "foo"; "bar" ] ] + in + let* () = + fold + (Some (`Ge 2)) + [ [ "foo"; "toto" ]; [ "foo"; "bar"; "toto" ] ] + [ [ "foo"; "bar" ] ] + in + fold (Some (`Gt 2)) [ [ "foo"; "bar"; "toto" ] ] [] >>= fun () -> + let* v1 = S.Tree.remove v1 [ "foo"; "bar"; "toto" ] in + let* v = S.Tree.find v1 [ "foo"; "toto" ] in + Alcotest.(check (option string)) "remove" (Some foo1) v; + let v1 = S.Tree.empty () in + let* s = S.Tree.stats v1 in + Alcotest.(check stats_t) "empty stats" empty_stats s; + let* v1 = S.Tree.add v1 [ "foo"; "1" ] foo1 in + let* v1 = S.Tree.add v1 [ "foo"; "2" ] foo2 in + let* s = S.Tree.stats v1 in + Alcotest.(check stats_t) + "stats 1" + { S.Tree.nodes = 2; leafs = 2; skips = 0; depth = 2; width = 2 } + s; + let* v1 = S.Tree.remove v1 [ "foo"; "1" ] in + let* v1 = S.Tree.remove v1 [ "foo"; "2" ] in + let* s = S.Tree.stats v1 in + Alcotest.(check stats_t) "empty stats" empty_stats s; + S.set_tree_exn t ~info:(infof "empty tree") [] v1 >>= fun () -> + let* head = S.Head.get t in + S.Commit.key head |> fun head -> + let* commit = B.Commit.find (ct repo) head in + let node = B.Commit.Val.node (get commit) in + let* node = B.Node.find (n repo) node in + check + T.(option B.Node.Val.t) + "empty tree" + (Some (B.Node.Val.empty ())) + node; + + (* Testing [Tree.diff] *) + let contents_t = T.pair S.contents_t S.metadata_t in + let diff = T.(pair S.path_t (Irmin.Diff.t contents_t)) in + let check_diffs = checks diff in + let check_val = check T.(option contents_t) in + let check_ls = checks T.(pair S.step_t S.tree_t) in + let normal c = Some (c, S.Metadata.default) in + let d0 = S.Metadata.default in + let v0 = S.Tree.empty () in + let v1 = S.Tree.empty () in + let v2 = S.Tree.empty () in + let* v1 = S.Tree.add v1 [ "foo"; "1" ] foo1 in + let* f = S.Tree.find_all v1 [ "foo"; "1" ] in + check_val "tree update" (normal foo1) f; + let* v1' = S.Tree.add v1 [ "foo"; "1" ] foo1 in + Alcotest.(check bool) "Tree.add keeps sharing" true (v1 == v1'); + let* v1' = S.Tree.remove v1 [ "foo"; "2" ] in + Alcotest.(check bool) "Tree.remove keeps sharing" true (v1 == v1'); + let* v1' = S.Tree.add_tree v1 [] v1 in + Alcotest.(check bool) "Tree.add_tree keeps sharing" true (v1 == v1'); + let* v2 = S.Tree.add v2 [ "foo"; "1" ] foo2 in + let* v2 = S.Tree.add v2 [ "foo"; "2" ] foo1 in + let* d1 = S.Tree.diff v0 v1 in + check_diffs "diff 1" [ ([ "foo"; "1" ], `Added (foo1, d0)) ] d1; + let* d2 = S.Tree.diff v1 v0 in + check_diffs "diff 2" [ ([ "foo"; "1" ], `Removed (foo1, d0)) ] d2; + let* d3 = S.Tree.diff v1 v2 in + check_diffs "diff 3" + [ + ([ "foo"; "1" ], `Updated ((foo1, d0), (foo2, d0))); + ([ "foo"; "2" ], `Added (foo1, d0)); + ] + d3; + let* v3 = S.Tree.add v2 [ "foo"; "bar"; "1" ] foo1 in + let* d4 = S.Tree.diff v2 v3 in + check_diffs "diff 4" [ ([ "foo"; "bar"; "1" ], `Added (foo1, d0)) ] d4; + let* d5 = S.Tree.diff v3 v2 in + check_diffs "diff 4" [ ([ "foo"; "bar"; "1" ], `Removed (foo1, d0)) ] d5; + + (* Testing length *) + let check_length msg t = + let* n = S.Tree.length t [] in + let+ l = S.Tree.list t [] in + Alcotest.(check int) msg n (List.length l) + in + let* () = check_length "bindings1 length" v2 in + let* () = + let t = contents "foo" in + check_length "contents length" t + in + + (* Testing paginated lists *) + let tree = + let c ?(info = S.Metadata.default) blob = `Contents (blob, info) in + S.Tree.of_concrete + (`Tree + [ + ("aa", c "0"); + ("a", c "1"); + ("bbb", c "3"); + ("b", c "3"); + ("aaa", c "1"); + ]) + in + let* _ = S.set_tree_exn t ~info:(infof "add tree") [] tree in + let* e = S.Tree.get_tree tree [ "a" ] in + let ls = + [ + ("aa", contents "0"); + ("a", e); + ("bbb", contents "3"); + ("b", contents "3"); + ("aaa", e); + ] + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:2 tree [] in + let* l2 = S.Tree.list ~offset:2 ~length:2 tree [] in + let+ l3 = S.Tree.list ~offset:4 ~length:2 tree [] in + Alcotest.(check int) "size l1" 2 (List.length l1); + Alcotest.(check int) "size l2" 2 (List.length l2); + Alcotest.(check int) "size l3" 1 (List.length l3); + check_ls "2 paginated list" ls (l1 @ l2 @ l3) + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:3 tree [] in + let+ l2 = S.Tree.list ~offset:3 ~length:6 tree [] in + Alcotest.(check int) "size l1" 3 (List.length l1); + Alcotest.(check int) "size l2" 2 (List.length l2); + check_ls "3 paginated list" ls (l1 @ l2) + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:4 tree [] in + let+ l2 = S.Tree.list ~offset:4 ~length:4 tree [] in + Alcotest.(check int) "size l1" 4 (List.length l1); + Alcotest.(check int) "size l2" 1 (List.length l2); + check_ls "4 paginated list" ls (l1 @ l2) + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:5 tree [] in + let+ l2 = S.Tree.list ~offset:5 ~length:5 tree [] in + Alcotest.(check int) "size l1" 5 (List.length l1); + Alcotest.(check int) "size l2" 0 (List.length l2); + check_ls "5 paginated list" ls (l1 @ l2) + in + let* c0 = + S.Tree.singleton [ "foo"; "a" ] "1" + |> with_binding [ "foo"; "b"; "c" ] "2" + >>= with_binding [ "foo"; "c" ] "3" + >>= with_binding [ "foo"; "d" ] "4" + in + let* b = S.Tree.get_tree c0 [ "foo"; "b" ] in + let* ls = S.Tree.list c0 [ "foo" ] in + check_ls "list all" + [ + ("a", contents "1"); ("b", b); ("c", contents "3"); ("d", contents "4"); + ] + ls; + let* ls = S.Tree.list ~offset:2 c0 [ "foo" ] in + check_ls "list offset=2" [ ("c", contents "3"); ("d", contents "4") ] ls; + let* ls = S.Tree.list ~offset:2 ~length:1 c0 [ "foo" ] in + check_ls "list offset=2 length=1" [ ("c", contents "3") ] ls; + let* ls = S.Tree.list ~length:1 c0 [ "foo" ] in + check_ls "list length=1" [ ("a", contents "1") ] ls; + + (* Testing concrete representation *) + let* c0 = + Lwt.return (S.Tree.empty ()) + >>= with_binding [ "foo"; "a" ] "1" + >>= with_binding [ "foo"; "b"; "c" ] "2" + >>= with_binding [ "bar"; "d" ] "3" + >>= with_binding [ "e" ] "4" + in + let* t0 = c0 |> S.Tree.to_concrete >|= S.Tree.of_concrete in + let* () = + let+ d0 = S.Tree.diff c0 t0 in + check_diffs "concrete roundtrip" [] d0 + in + let* () = + let* c0' = S.Tree.list c0 [] in + let+ t0' = S.Tree.list t0 [] in + check_ls "concrete list /" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "foo" ] in + let+ t0' = S.Tree.list t0 [ "foo" ] in + check_ls "concrete tree list /foo" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "bar"; "d" ] in + let+ t0' = S.Tree.list t0 [ "bar"; "d" ] in + check_ls "concrete tree list /bar/d" c0' t0' + in + + (* Testing other tree operations. *) + let v0 = S.Tree.empty () in + let* c = S.Tree.to_concrete v0 in + (match c with + | `Tree [] -> () + | _ -> Alcotest.fail "Excpected empty tree"); + let* v0 = S.Tree.add v0 [] foo1 in + let* foo1' = S.Tree.find_all v0 [] in + check_val "read /" (normal foo1) foo1'; + let* v0 = S.Tree.add v0 [ "foo"; "1" ] foo1 in + let* foo1' = S.Tree.find_all v0 [ "foo"; "1" ] in + check_val "read foo/1" (normal foo1) foo1'; + let* v0 = S.Tree.add v0 [ "foo"; "2" ] foo2 in + let* foo2' = S.Tree.find_all v0 [ "foo"; "2" ] in + check_val "read foo/2" (normal foo2) foo2'; + let check_tree v = + let* ls = S.Tree.list v [ "foo" ] in + check_ls "path1" [ ("1", contents foo1); ("2", contents foo2) ] ls; + let* foo1' = S.Tree.find_all v [ "foo"; "1" ] in + check_val "foo1" (normal foo1) foo1'; + let* foo2' = S.Tree.find_all v [ "foo"; "2" ] in + check_val "foo2" (normal foo2) foo2'; + Lwt.return_unit + in + let* v0 = + Lwt_list.fold_left_s (fun v0 (k, v) -> S.Tree.add v0 k v) v0 nodes + in + check_tree v0 >>= fun () -> + S.set_tree_exn t ~info:(infof "update_path b/") [ "b" ] v0 >>= fun () -> + S.set_tree_exn t ~info:(infof "update_path a/") [ "a" ] v0 >>= fun () -> + let* ls = S.list t [ "b"; "foo" ] in + check_ls "path2" [ ("1", contents foo1); ("2", contents foo2) ] ls; + let* foo1' = S.find_all t [ "b"; "foo"; "1" ] in + check_val "foo1" (normal foo1) foo1'; + let* foo2' = S.find_all t [ "a"; "foo"; "2" ] in + check_val "foo2" (normal foo2) foo2'; + let* v0 = S.get_tree t [ "b" ] in + check_tree v0 >>= fun () -> + S.set_exn t ~info:(infof "update b/x") [ "b"; "x" ] foo1 >>= fun () -> + let* v2 = S.get_tree t [ "b" ] in + let* v1 = S.Tree.add v0 [ "y" ] foo2 in + let* v' = + Irmin.Merge.(f S.Tree.merge ~old:(promise v0) v1 v2) + >>= merge_exn "merge trees" + in + S.set_tree_exn t ~info:(infof "merge_path") [ "b" ] v' >>= fun () -> + let* foo1' = S.find_all t [ "b"; "x" ] in + let* foo2' = S.find_all t [ "b"; "y" ] in + check_val "merge: b/x" (normal foo1) foo1'; + check_val "merge: b/y" (normal foo2) foo2'; + let* () = + Lwt_list.iteri_s + (fun i (k, v) -> + let* v' = S.find_all t ("a" :: k) in + check_val ("a" ^ string_of_int i) (normal v) v'; + let* v' = S.find_all t ("b" :: k) in + check_val ("b" ^ string_of_int i) (normal v) v'; + Lwt.return_unit) + nodes + in + let* v2 = S.get_tree t [ "b" ] in + let* _ = S.Tree.find_all v2 [ "foo"; "1" ] in + let* v2 = S.Tree.add v2 [ "foo"; "1" ] foo2 in + S.set_tree_exn t ~info:(infof "v2") [ "b" ] v2 >>= fun () -> + let* foo2' = S.find_all t [ "b"; "foo"; "1" ] in + check_val "update tree" (normal foo2) foo2'; + let* v3 = S.get_tree t [ "b" ] in + let* _ = S.Tree.find_all v3 [ "foo"; "1" ] in + let* v3 = S.Tree.remove v3 [ "foo"; "1" ] in + S.set_tree_exn t ~info:(infof "v3") [ "b" ] v3 >>= fun () -> + let* foo2' = S.find_all t [ "b"; "foo"; "1" ] in + check_val "remove tree" None foo2'; + let* r1 = r1 ~repo in + let* r2 = r2 ~repo in + let i0 = S.Info.empty in + let* c = + S.Commit.v repo ~info:S.Info.empty + ~parents:[ S.Commit.key r1; S.Commit.key r2 ] + v3 + in + S.Head.set t c >>= fun () -> + let* h = S.Head.get t in + S.Commit.info h |> fun i -> + check S.Info.t "commit info" i0 i; + let* tt = S.of_commit h in + let* g = S.history tt in + let pred = S.History.pred g h in + checks (S.commit_t repo) "head" [ r1; r2 ] pred; + let* foo2'' = S.find_all tt [ "b"; "foo"; "1" ] in + check_val "remove tt" None foo2''; + let vx = "VX" in + let px = [ "x"; "y"; "z" ] in + S.set_exn tt ~info:(infof "update") px vx >>= fun () -> + let* tree = S.get_tree tt [] in + S.Tree.clear tree; + let* s = S.Tree.stats tree in + Alcotest.(check stats_t) + "lazy stats" + { S.Tree.nodes = 0; leafs = 0; skips = 1; depth = 0; width = 0 } + s; + S.Tree.clear tree; + let* s = S.Tree.stats ~force:true tree in + Alcotest.(check stats_t) + "forced stats" + { S.Tree.nodes = 404; leafs = 103; skips = 0; depth = 5; width = 103 } + s; + let* vx' = S.Tree.find_all tree px in + check_val "updates" (normal vx) vx'; + let v = S.Tree.singleton [] vx in + let* () = + S.set_tree_exn t ~info:(infof "update file as tree") [ "a" ] v + in + let* vx' = S.find_all t [ "a" ] in + check_val "update file as tree" (normal vx) vx'; + B.Repo.close repo + in + run x test + + let pp_proof = Irmin.Type.pp (S.Tree.Proof.t S.Tree.Proof.tree_t) + let pp_stream = Irmin.Type.pp (S.Tree.Proof.t S.Tree.Proof.stream_t) + + let test_proofs x () = + let test repo = + (* Testing Merkle proof *) + let large_dir = + List.init 1000 (fun i -> + let v = string_of_int i in + ([ "dir"; v ], "BLOB:" ^ v)) + in + let* c0 = + Lwt.return (S.Tree.empty ()) + >>= with_binding [ "foo"; "a" ] "1" + >>= with_binding [ "foo"; "b"; "c" ] "2" + >>= with_binding [ "bar"; "d" ] "3" + >>= with_binding [ "e" ] "4" + >>= fun t -> + Lwt_list.fold_left_s (fun acc (k, v) -> S.Tree.add acc k v) t large_dir + in + let to_proof t = + let* store = S.empty repo in + let* () = S.set_tree_exn ~info:(infof "to_proof") store [] t in + let key = + match S.Tree.key t with None -> assert false | Some k -> k + in + let rec aux p t = + let* bindings = + Lwt.catch + (fun () -> S.Tree.list t []) + (function + | S.Tree.Pruned_hash _ -> Lwt.return [] | e -> Lwt.fail e) + in + Lwt_list.iter_s (fun (s, v) -> aux (p @ [ s ]) v) bindings + in + S.Tree.produce_proof repo key (fun t -> + let+ () = aux [] t in + (t, ())) + in + let* p0, () = to_proof c0 in + [%log.debug "p0=%a" pp_proof p0]; + let t0 = S.Tree.Proof.to_tree p0 in + let* () = + let+ d0 = S.Tree.diff c0 t0 in + check_diffs "proof roundtrip" [] d0 + in + let* () = + let* c0' = S.Tree.list c0 [] in + let+ t0' = S.Tree.list t0 [] in + check_ls "proof list /" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "foo" ] in + let+ t0' = S.Tree.list t0 [ "foo" ] in + check_ls "proof tree list /foo" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "bar"; "d" ] in + let+ t0' = S.Tree.list t0 [ "bar"; "d" ] in + check_ls "proof tree list /bar/d" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "dir" ] in + let+ t0' = S.Tree.list t0 [ "dir" ] in + check_ls "proof tree list /dir" c0' t0' + in + let add_noise n prefix = + List.map (fun k -> (prefix @ [ k ], k)) (List.init n string_of_int) + in + let bindings = + [ + ([ "foo"; "age" ], "0"); + ([ "foo"; "version" ], "1"); + ([ "bar"; "age" ], "2"); + ([ "bar"; "version" ], "3"); + ] + @ add_noise 100 [ "foo" ] + @ add_noise 10 [ "hey" ] + @ add_noise 50 [ "bar" ] + in + let increment = function + | None -> assert false + | Some i -> Some (int_of_string i + 1 |> string_of_int) + in + let check_proof_f0 p = + let t = S.Tree.Proof.to_tree p in + let* i = S.Tree.find t [ "bar"; "age" ] in + Alcotest.(check (option string)) + "inside: find bar/age in proof" (Some "2") i; + let* i = S.Tree.find t [ "bar"; "version" ] in + Alcotest.(check (option string)) + "inside: find bar/version in proof" (Some "3") i; + let* i = S.Tree.find t [ "hello"; "there" ] in + Alcotest.(check (option string)) + "inside: do not find hello/there in proof" None i; + let+ () = + Lwt.catch + (fun () -> + let+ _ = S.Tree.find t [ "foo"; "version" ] in + Alcotest.fail "inside: should have raise: pruned_hash exn") + (function + | S.Tree.Pruned_hash _ | B.Node.Val.Dangling_hash _ -> + Lwt.return () + | e -> Lwt.fail e) + in + () + in + + let check_proof_f1 p = + let t = S.Tree.Proof.to_tree p in + let+ i = S.Tree.find t [ "foo"; "version" ] in + Alcotest.(check (option string)) + "outside: find foo/version" (Some "1") i + in + + let init_tree bindings = + let tree = S.Tree.empty () in + let* tree = + Lwt_list.fold_left_s + (fun tree (k, v) -> S.Tree.add tree k v) + tree bindings + in + let* store = S.empty repo in + let* () = S.set_tree_exn ~info:(infof "init_tree") store [] tree in + S.tree store + in + let* tree = init_tree bindings in + let key = + match S.Tree.key tree with None -> assert false | Some k -> k + in + + let f0 t0 = + let* t1 = S.Tree.update t0 [ "foo"; "age" ] increment in + let* t2 = S.Tree.update t1 [ "bar"; "age" ] increment in + let* t3 = S.Tree.get_tree t2 [ "bar" ] in + let* t4 = S.Tree.add_tree t2 [ "hello"; "there" ] t3 in + let* v = S.Tree.get t4 [ "hello"; "there"; "version" ] in + Alcotest.(check string) "hello/there/version" "3" v; + let t = S.Tree.empty () in + let* t5 = S.Tree.add_tree t [ "dir1"; "dir2" ] t4 in + let* v = S.Tree.get t5 [ "dir1"; "dir2"; "bar"; "age" ] in + Alcotest.(check string) "dir1/dir2/bar/age" "3" v; + let* t = S.Tree.remove t4 [ "bar" ] in + + (* Trigger certain paths in [S.Tree] during "verify" *) + let portable = + (* During "verify" [portable] is [Pruned] with [portable] in env *) + t0 + in + let portable_dirty = t in + let trigger_node_to_map t = + S.Tree.fold ~depth:(`Eq 1) ~order:`Sorted ~force:`True t () + in + let* () = trigger_node_to_map portable in + let* () = trigger_node_to_map portable_dirty in + let trigger_node_length t = + let+ (_ : int) = S.Tree.length t [] in + () + in + let* () = trigger_node_length portable in + let* () = trigger_node_length portable_dirty in + let trigger_node_fold_undefined t = + S.Tree.fold ~depth:(`Eq 1) ~order:`Undefined ~force:`True t () + in + let* () = trigger_node_fold_undefined portable in + let* () = trigger_node_fold_undefined portable_dirty in + let (_ : bool) = S.Tree.is_empty portable in + let trigger_node_to_backend_portable t = + match S.Tree.destruct t with + | `Contents _ -> assert false + | `Node n -> + let+ _ = S.to_backend_portable_node n in + () + in + let* () = trigger_node_to_backend_portable portable_dirty in + + Lwt.return (t, ()) + in + let f1 t0 = + let* p0, () = S.Tree.produce_proof repo key f0 in + let* () = check_proof_f0 p0 in + let+ v = S.Tree.get t0 [ "foo"; "version" ] in + Alcotest.(check string) "foo/version" "1" v; + (t0, ()) + in + let* p, () = S.Tree.produce_proof repo key f1 in + + let* () = check_proof_f1 p in + + let check_proof f = + let* p, () = S.Tree.produce_proof repo key f in + [%log.debug "Verifying proof %a" pp_proof p]; + let+ r = S.Tree.verify_proof p f in + match r with + | Ok (_, ()) -> () + | Error e -> + Alcotest.failf "check_proof: %a" + (Irmin.Type.pp S.Tree.verifier_error_t) + e + in + let* () = Lwt_list.iter_s check_proof [ f0; f1 ] in + + let check_stream f = + let* p, () = S.Tree.produce_stream repo key f in + [%log.debug "Verifying stream %a" pp_stream p]; + let+ r = S.Tree.verify_stream p f in + match r with + | Ok (_, ()) -> () + | Error e -> + Alcotest.failf "check_stream: %a" + (Irmin.Type.pp S.Tree.verifier_error_t) + e + in + let* () = Lwt_list.iter_s check_stream [ f0; f1 ] in + + (* check env sharing *) + let tree () = + S.Tree.of_concrete + (`Tree [ ("foo", `Contents ("bar", S.Metadata.default)) ]) + in + let contents () = + S.Tree.of_concrete (`Contents ("bar", S.Metadata.default)) + in + let check_env_empty msg t b = + let env = S.Tree.Private.get_env t in + Alcotest.(check bool) msg b (S.Tree.Private.Env.is_empty env) + in + let check_env msg t t' = + let env = S.Tree.Private.get_env t in + let env' = S.Tree.Private.get_env t' in + check S.Tree.Private.Env.t msg env env' + in + let x = ref None in + let* _ = + S.Tree.produce_proof repo key (fun t -> + check_env_empty "env should be set inside the proof" t false; + x := Some t; + + let t0 = tree () in + check_env_empty "env should not be set for fresh trees" t0 true; + + (* test changing subtress: check that envirnoment is + attached only the tree roots *) + let* t1 = S.Tree.add_tree t [ "foo" ] t0 in + check_env_empty "1: t's env should not change" t false; + check_env_empty "1: t0's env should not change" t0 true; + check_env "1: t1's env should be the same as t's" t1 t; + + let t0 = contents () in + let* t1 = S.Tree.add_tree t [ "foo" ] t0 in + check_env_empty "2: t's env should not change" t false; + check_env_empty "2: t0's env should not change" t0 true; + check_env "2: t1's env should be the same as t's" t1 t; + + (* test changing roots *) + let t0 = tree () in + let* t1 = S.Tree.add_tree t [] t0 in + check_env_empty "3: t's env should not change" t false; + check_env_empty "3: t0's env should not change" t0 true; + check_env "3: t1's env should be the same as t0's" t1 t0; + + let t0 = contents () in + let* t1 = S.Tree.add_tree t [] t0 in + check_env_empty "4: t's env should not change" t false; + check_env_empty "4: t0's env should not change" t0 true; + check_env "4: t1's env should be the same as t0's" t1 t0; + + (* check subtrees *) + let* t2 = S.Tree.get_tree t [ "foo" ] in + check_env "5: t2's env should be the same as t's" t2 t; + let* t3 = S.Tree.get_tree t [ "foo"; "age" ] in + check_env "5: t3's env should be the same as t's" t3 t; + + Lwt.return (t, ())) + in + let t = match !x with Some t -> t | None -> assert false in + check_env_empty "env is unset outside of the proof)" t true; + + (* test negative proofs *) + let check_bad_proof p = + let+ r = S.Tree.verify_proof p f0 in + match r with + | Ok _ -> Alcotest.fail "verify should have failed" + | Error _ -> () + in + + let* p0, () = S.Tree.produce_proof repo key f0 in + let proof ?(before = S.Tree.Proof.before p0) + ?(after = S.Tree.Proof.after p0) ?(state = S.Tree.Proof.state p0) () = + S.Tree.Proof.v ~before ~after state + in + let wrong_hash = B.Contents.Hash.hash "not the right hash!" in + let wrong_kinded_hash = `Node wrong_hash in + let* () = check_bad_proof (proof ~before:wrong_kinded_hash ()) in + let* () = check_bad_proof (proof ~after:wrong_kinded_hash ()) in + let* _ = S.Tree.verify_proof (proof ()) f0 in + let some_contents : S.Tree.Proof.tree list = + [ + Blinded_node wrong_hash; + Node []; + Inode { length = 1024; proofs = [] }; + Blinded_contents (wrong_hash, S.Metadata.default); + Contents ("yo", S.Metadata.default); + ] + in + let* () = + Lwt_list.iter_s + (fun c -> check_bad_proof (proof ~state:c ())) + some_contents + in + + (* test negative streams *) + let check_bad_stream p = + let+ r = S.Tree.verify_stream p f0 in + match r with + | Ok _ -> + Alcotest.failf "verify_stream should have failed %a" pp_stream p + | Error _ -> () + in + + let* p0, () = S.Tree.produce_stream repo key f0 in + let proof ?(before = S.Tree.Proof.before p0) + ?(after = S.Tree.Proof.after p0) ?(contents = S.Tree.Proof.state p0) + () = + S.Tree.Proof.v ~before ~after contents + in + let wrong_hash = B.Contents.Hash.hash "not the right hash!" in + let wrong_kinded_hash = `Node wrong_hash in + let* () = check_bad_stream (proof ~before:wrong_kinded_hash ()) in + let* () = check_bad_stream (proof ~after:wrong_kinded_hash ()) in + let* _ = S.Tree.verify_stream (proof ()) f0 in + let some_contents : S.Tree.Proof.stream list = + let s : S.Tree.Proof.elt list -> S.Tree.Proof.stream = List.to_seq in + let ok = List.of_seq (S.Tree.Proof.state p0) in + [ + s []; + s [ Node [] ]; + s [ Inode { length = 1024; proofs = [] } ]; + s [ Contents "yo" ]; + s (ok @ [ Node [] ]); + ] + in + let* () = + let x = ref 1 in + Lwt_list.iter_s + (fun c -> + incr x; + check_bad_stream (proof ~contents:c ())) + some_contents + in + + B.Repo.close repo + in + run x test + + let test_wide_nodes x () = + let test repo = + let size = 500_000 in + let c0 = S.Tree.empty () in + let rec wide_node i c = + if i >= size then Lwt.return c + else + S.Tree.add c [ "foo"; string_of_int i ] (string_of_int i) >>= fun c -> + wide_node (i + 1) c + in + wide_node 0 c0 >>= fun c -> + S.Tree.list c [ "foo" ] >>= fun ls -> + Alcotest.(check int) "list wide dir" size (List.length ls); + S.Tree.fold ~force:`True c ~uniq:`False + ~contents:(fun k _ i -> + Alcotest.(check int) "contents at [foo; i]" (List.length k) 2; + Lwt.return (i + 1)) + ~node:(fun k _ i -> + if not (List.length k = 0 || List.length k = 1) then + Alcotest.failf "nodes should be at [] and [foo], got %a" + (Irmin.Type.pp S.path_t) k; + Lwt.return i) + 0 + >>= fun nb_contents -> + Alcotest.(check int) "nb of contents folded over" size nb_contents; + S.Tree.remove c [ "foo"; "499999" ] >>= fun c1 -> + S.Tree.add c0 [] "499999" >>= fun c2 -> + S.Tree.add_tree c1 [ "foo"; "499999" ] c2 >>= fun c' -> + let h' = S.Tree.hash c' in + let h = S.Tree.hash c in + check S.Hash.t "same tree" h h'; + let* c1 = S.Tree.get_tree c [ "foo" ] in + let* _ = + S.Backend.Repo.batch repo (fun c n _ -> S.save_tree repo c n c1) + in + (match S.Tree.destruct c1 with + | `Contents _ -> Alcotest.fail "got `Contents, expected `Node" + | `Node node -> ( + let* v = S.to_backend_node node in + let () = + let ls = B.Node.Val.list v in + Alcotest.(check int) "list wide node" size (List.length ls) + in + let* bar_key = with_contents repo (fun t -> B.Contents.add t "bar") in + let k = normal bar_key in + let v1 = B.Node.Val.add v "x" k in + let* () = + let h' = B.Node.Hash.hash v1 in + let+ h = with_node repo (fun n -> B.Node.add n v1) in + check B.Node.Hash.t "wide node + x: hash(v) = add(v)" + (B.Node.Key.to_hash h) h' + in + let () = + let v2 = B.Node.Val.add v "x" k in + check B.Node.Val.t "add x" v1 v2 + in + let () = + let v0 = B.Node.Val.remove v1 "x" in + check B.Node.Val.t "remove x" v v0 + in + let* () = + let v3 = B.Node.Val.remove v "1" in + let h' = B.Node.Hash.hash v3 in + with_node repo (fun n -> B.Node.add n v3) >|= fun h -> + check B.Node.Hash.t "wide node - 1 : hash(v) = add(v)" + (B.Node.Key.to_hash h) h' + in + (match B.Node.Val.find v "499999" with + | None | Some (`Node _) -> Alcotest.fail "value 499999 not found" + | Some (`Contents (x, _)) -> + let x = B.Contents.Key.to_hash x in + let x' = B.Contents.Hash.hash "499999" in + check B.Contents.Hash.t "find 499999" x x'); + match B.Node.Val.find v "500000" with + | None -> Lwt.return_unit + | Some _ -> Alcotest.fail "value 500000 should not be found")) + >>= fun () -> B.Repo.close repo + in + run x test + + let test_commit_wide_node x () = + let test repo = + let size = 500_000 in + let c0 = S.Tree.empty () in + let rec wide_node i c = + if i >= size then Lwt.return c + else + S.Tree.add c [ "foo"; string_of_int i ] (string_of_int i) >>= fun c -> + wide_node (i + 1) c + in + wide_node 0 c0 >>= fun c -> + S.main repo >>= fun t -> + S.set_tree_exn t [ "wide" ] ~info:(infof "commit_wide_nodes") c + >>= fun () -> + S.list t [ "wide"; "foo" ] >>= fun ls -> + Alcotest.(check int) "commit wide node list" size (List.length ls); + B.Repo.close repo + in + run x test + + module Sync = Irmin.Sync.Make (S) + + let test_sync x () = + let test repo = + let* t1 = S.main repo in + S.set_exn t1 ~info:(infof "update a/b") [ "a"; "b" ] v1 >>= fun () -> + let* h = S.Head.get t1 in + let* _r1 = S.Head.get t1 in + S.set_exn t1 ~info:(infof "update a/c") [ "a"; "c" ] v2 >>= fun () -> + let* r2 = S.Head.get t1 in + S.set_exn t1 ~info:(infof "update a/d") [ "a"; "d" ] v1 >>= fun () -> + let* _r3 = S.Head.get t1 in + let* h = S.history t1 ~min:[ h ] in + Alcotest.(check int) "history-v" 3 (S.History.nb_vertex h); + Alcotest.(check int) "history-e" 2 (S.History.nb_edges h); + let remote = Irmin.remote_store (module S) t1 in + let* partial = Sync.fetch_exn t1 ~depth:0 remote in + let partial = + match partial with + | `Head x -> x + | `Empty -> failwith "no head: partial" + in + let* full = Sync.fetch_exn t1 remote in + let full = + match full with `Head x -> x | `Empty -> failwith "no head: full" + in + (* Restart a fresh store and import everything in there. *) + let tag = "export" in + let* t2 = S.of_branch repo tag in + S.Head.set t2 partial >>= fun () -> + let* b1 = S.mem t2 [ "a"; "b" ] in + Alcotest.(check bool) "mem-ab" true b1; + let* b2 = S.mem t2 [ "a"; "c" ] in + Alcotest.(check bool) "mem-ac" true b2; + let* b3 = S.mem t2 [ "a"; "d" ] in + Alcotest.(check bool) "mem-ad" true b3; + let* v1' = S.get t2 [ "a"; "d" ] in + check S.contents_t "v1" v1 v1'; + S.Head.set t2 r2 >>= fun () -> + let* b4 = S.mem t2 [ "a"; "d" ] in + Alcotest.(check bool) "mem-ab" false b4; + S.Head.set t2 full >>= fun () -> + S.Head.set t2 r2 >>= fun () -> + let* b4 = S.mem t2 [ "a"; "d" ] in + Alcotest.(check bool) "mem-ad" false b4; + B.Repo.close repo + in + run x test + + module Dot = Irmin.Dot (S) + + let output_file x t file = + let buf = Buffer.create 1024 in + let date d = + let tm = Unix.localtime (Int64.to_float d) in + Fmt.str "%2d:%2d:%2d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + in + Dot.output_buffer t ~date buf >>= fun () -> + let oc = + open_out_bin + (Filename.get_temp_dir_name () / Fmt.str "%s-%s.dot" x.name file) + in + output_string oc (Buffer.contents buf); + close_out oc; + Lwt.return_unit + + let test_merge ?hook x () = + let test repo = + let v1 = "X1" in + let v2 = "X2" in + let v3 = "X3" in + let* t1 = S.main repo in + let* () = + S.set_exn t1 ~info:(infof "update a/b/a") [ "a"; "b"; "a" ] v1 + in + let* () = + S.set_exn t1 ~info:(infof "update a/b/b") [ "a"; "b"; "b" ] v2 + in + let* () = + S.set_exn t1 ~info:(infof "update a/b/c") [ "a"; "b"; "c" ] v3 + in + let test = "test" in + let* t2 = S.clone ~src:t1 ~dst:test in + let* () = + S.set_exn t1 ~info:(infof "update main:a/b/b") [ "a"; "b"; "b" ] v1 + in + let* () = + S.set_exn t1 ~info:(infof "update main:a/b/b") [ "a"; "b"; "b" ] v3 + in + let* () = + S.set_exn t2 ~info:(infof "update test:a/b/c") [ "a"; "b"; "c" ] v1 + in + output_file x t1 "before" >>= fun () -> + let* m = S.merge_into ~info:(infof "merge test into main") t2 ~into:t1 in + merge_exn "m" m >>= fun () -> + may_with_branch [ t1 ] repo hook >>= fun () -> + output_file x t1 "after" >>= fun () -> + let* v1' = S.get t1 [ "a"; "b"; "c" ] in + let* v2' = S.get t2 [ "a"; "b"; "b" ] in + let* v3' = S.get t1 [ "a"; "b"; "b" ] in + check S.contents_t "v1" v1 v1'; + check S.contents_t "v2" v2 v2'; + check S.contents_t "v3" v3 v3'; + B.Repo.close repo + in + run x test + + (* in this test an outdated reference to a tree is used by a commit: [tree] is + the tree with root [x] created by [c1] and modified by [c2]. [c3] reuse [tree] + which implicitly deletes the changes of [c2]. *) + let test_merge_outdated_tree x () = + let check_val = check T.(option S.contents_t) in + let none_fail f msg = + f >>= function None -> Alcotest.fail msg | Some c -> Lwt.return c + in + let test repo = + let vx = "VX" in + let vy = "VY" in + let old () = Lwt.return (Ok None) in + let* t = S.main repo in + S.set_exn t ~info:(infof "add x/y/z") [ "x"; "y"; "z" ] vx >>= fun () -> + let* _c1 = none_fail (S.Head.find t) "head not found" in + let* tree = S.get_tree t [ "x" ] in + S.set_exn t ~info:(infof "add u/x/y") [ "u"; "x"; "y" ] vy >>= fun () -> + let* c2 = none_fail (S.Head.find t) "head not found" in + let* tree3 = S.Tree.add tree [ "x"; "z" ] vx in + S.set_tree_exn t ~info:(infof "update") [ "u" ] tree3 >>= fun () -> + let* c3 = none_fail (S.Head.find t) "head not found" in + let info () = S.Commit.info c3 in + with_commit repo (fun commit_t -> + Irmin.Merge.f + (B.Commit.merge commit_t ~info) + ~old + (Some (S.Commit.key c3)) + (Some (S.Commit.key c2))) + >>= merge_exn "commit" + >>= function + | None -> Lwt.return_unit + | Some c4 -> + let* k = none_fail (S.Commit.of_key repo c4) "of hash" in + S.Branch.set repo "foo" k >>= fun () -> + let* t = S.of_branch repo "foo" in + let* vy' = S.find t [ "u"; "x"; "y" ] in + check_val "vy after merge" None vy'; + B.Repo.close repo + in + run x test + + let test_merge_unrelated ?hook x () = + run x @@ fun repo -> + let v1 = "X1" in + let* foo = S.of_branch repo "foo" in + let* bar = S.of_branch repo "bar" in + S.set_exn foo ~info:(infof "update foo:a") [ "a" ] v1 >>= fun () -> + S.set_exn bar ~info:(infof "update bar:b") [ "b" ] v1 >>= fun () -> + may_with_branch [ foo; bar ] repo hook >>= fun () -> + let* _ = + S.merge_into ~info:(infof "merge bar into foo") bar ~into:foo + >>= merge_exn "merge unrelated" + in + B.Repo.close repo + + let rec write fn = function + | 0 -> [] + | i -> (fun () -> fn i >>= Lwt.pause) :: write fn (i - 1) + + let perform l = Lwt_list.iter_p (fun f -> f ()) l + + let rec read fn check = function + | 0 -> [] + | i -> (fun () -> fn i >|= fun v -> check i v) :: read fn check (i - 1) + + let test_concurrent_low x () = + let test_branches repo = + let k = b1 in + let* v = r1 ~repo in + let write = write (fun _i -> S.Branch.set repo k v) in + let read = + read + (fun _i -> S.Branch.find repo k >|= get) + (fun i -> check (S.commit_t repo) (Fmt.str "tag %d" i) v) + in + perform (write 1) >>= fun () -> + perform (write 10 @ read 10 @ write 10 @ read 10) + in + let test_contents repo = + let* k = kv2 ~repo in + let v = v2 in + let t = B.Repo.contents_t repo in + let write = + write (fun _i -> + let* _ = with_contents repo (fun t -> B.Contents.add t v) in + Lwt.return_unit) + in + let read = + read + (fun _i -> B.Contents.find t k >|= get) + (fun i -> check S.contents_t (Fmt.str "contents %d" i) v) + in + perform (write 1) >>= fun () -> + perform (write 10 @ read 10 @ write 10 @ read 10) + in + run x (fun repo -> + Lwt.choose [ test_branches repo; test_contents repo ] >>= fun () -> + B.Repo.close repo) + + let test_concurrent_updates x () = + let test_one repo = + let k = [ "a"; "b"; "d" ] in + let v = "X1" in + let* t1 = S.main repo in + let* t2 = S.main repo in + let write t = + write (fun i -> S.set_exn t ~info:(infof "update: one %d" i) k v) + in + let read t = + read + (fun _ -> S.get t k) + (fun i -> check S.contents_t (Fmt.str "update: one %d" i) v) + in + perform (write t1 10 @ write t2 10) >>= fun () -> perform (read t1 10) + in + let test_multi repo = + let k i = [ "a"; "b"; "c"; string_of_int i ] in + let v i = Fmt.str "X%d" i in + let* t1 = S.main repo in + let* t2 = S.main repo in + let write t = + write (fun i -> + S.set_exn t ~info:(infof "update: multi %d" i) (k i) (v i)) + in + let read t = + read + (fun i -> S.get t (k i)) + (fun i -> check S.contents_t (Fmt.str "update: multi %d" i) (v i)) + in + perform (write t1 10 @ write t2 10) >>= fun () -> perform (read t1 10) + in + run x (fun repo -> + test_one repo >>= fun () -> + test_multi repo >>= fun () -> B.Repo.close repo) + + let test_concurrent_merges x () = + let test repo = + let k i = [ "a"; "b"; "c"; string_of_int i ] in + let v i = Fmt.str "X%d" i in + let* t1 = S.main repo in + let* t2 = S.main repo in + let write t n = + write (fun i -> + let tag = Fmt.str "tmp-%d-%d" n i in + let* m = S.clone ~src:t ~dst:tag in + S.set_exn m ~info:(infof "update") (k i) (v i) >>= fun () -> + Lwt.pause () >>= fun () -> + S.merge_into ~info:(infof "update: multi %d" i) m ~into:t + >>= merge_exn "update: multi") + in + let read t = + read + (fun i -> S.get t (k i)) + (fun i -> check S.contents_t (Fmt.str "update: multi %d" i) (v i)) + in + S.set_exn t1 ~info:(infof "update") (k 0) (v 0) >>= fun () -> + perform (write t1 1 10 @ write t2 2 10) >>= fun () -> + perform (read t1 10) >>= fun () -> B.Repo.close repo + in + run x test + + let pp_write_error = Irmin.Type.pp S.write_error_t + let tree_t = testable S.tree_t + + let test_with_tree x () = + let test repo = + let* t = S.main repo in + let update ?retries key strategy r w = + S.with_tree t ?retries ~info:(infof "with-tree") ~strategy key (fun _ -> + let+ v = Lwt_mvar.take r in + Some (S.Tree.of_contents v)) + >>= Lwt_mvar.put w + in + let check_ok = function + | Ok () -> () + | Error e -> Alcotest.failf "%a" pp_write_error e + in + let check_test e = function + | Error (`Test_was e') -> + Alcotest.(check (option tree_t)) "test-was" e e' + | Ok () -> Alcotest.fail "error expected" + | Error e -> + Alcotest.failf "an other error was expected: %a" pp_write_error e + in + let check_conflict = function + | Error (`Conflict _) -> () + | Ok () -> Alcotest.fail "error expected" + | Error e -> + Alcotest.failf "an other error was expected: %a" pp_write_error e + in + let set () = + let rx = Lwt_mvar.create_empty () in + let wx = Lwt_mvar.create_empty () in + let ry = Lwt_mvar.create_empty () in + let wy = Lwt_mvar.create_empty () in + S.set_exn t ~info:(infof "init") [ "a" ] "0" >>= fun () -> + Lwt.join + [ + update [ "a" ] ~retries:0 `Set rx wx; + update [ "a" ] ~retries:0 `Set ry wy; + ( Lwt_mvar.put rx "1" >>= fun () -> + Lwt_mvar.take wx >|= check_ok >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "set x" "1" a; + Lwt_mvar.put ry "2" >>= fun () -> + Lwt_mvar.take wy >|= check_ok >>= fun () -> + let+ a = S.get t [ "a" ] in + Alcotest.(check string) "set y" "2" a ); + ] + in + let test_and_set () = + let rx = Lwt_mvar.create_empty () in + let wx = Lwt_mvar.create_empty () in + let ry = Lwt_mvar.create_empty () in + let wy = Lwt_mvar.create_empty () in + let rz = Lwt_mvar.create_empty () in + let wz = Lwt_mvar.create_empty () in + S.set_exn t ~info:(infof "init") [ "a" ] "0" >>= fun () -> + Lwt.join + [ + update [ "a" ] ~retries:0 `Test_and_set rx wx; + update [ "a" ] ~retries:0 `Test_and_set ry wy; + update [ "a" ] ~retries:1 `Test_and_set rz wz; + ( Lwt_mvar.put rx "1" >>= fun () -> + Lwt_mvar.take wx >|= check_ok >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "test-and-set x" "1" a; + Lwt_mvar.put ry "2" >>= fun () -> + let* e = Lwt_mvar.take wy in + check_test (Some (S.Tree.of_contents "1")) e; + let* a = S.get t [ "a" ] in + Alcotest.(check string) "test-and-set y" "1" a; + Lwt_mvar.put rz "3" >>= fun () -> + (* there's a conflict, the transaction is restarted so need to feed a + new value *) + Lwt_mvar.put rz "4" >>= fun () -> + Lwt_mvar.take wz >|= check_ok >>= fun () -> + let+ a = S.get t [ "a" ] in + Alcotest.(check string) "test-and-set z" "4" a ); + ] + in + let merge () = + let rx = Lwt_mvar.create_empty () in + let wx = Lwt_mvar.create_empty () in + let ry = Lwt_mvar.create_empty () in + let wy = Lwt_mvar.create_empty () in + let rz = Lwt_mvar.create_empty () in + let wz = Lwt_mvar.create_empty () in + S.set_exn t ~info:(infof "init") [ "a" ] "0" >>= fun () -> + Lwt.join + [ + update [ "a" ] ~retries:0 `Merge rx wx; + update [ "a" ] ~retries:0 `Merge ry wy; + update [ "a" ] ~retries:1 `Merge rz wz; + ( Lwt_mvar.put rx "1" >>= fun () -> + Lwt_mvar.take wx >|= check_ok >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "merge x" "1" a; + Lwt_mvar.put ry "2" >>= fun () -> + Lwt_mvar.take wy >|= check_conflict >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "merge y" a "1"; + Lwt_mvar.put rz "3" >>= fun () -> + (* there's a conflict, the transaction is restarted so need to feed a + new value *) + Lwt_mvar.put rz "4" >>= fun () -> + Lwt_mvar.take wz >|= check_ok >>= fun () -> + let+ a = S.get t [ "a" ] in + Alcotest.(check string) "merge z" a "4" ); + ] + in + set () >>= test_and_set >>= merge >>= fun () -> B.Repo.close repo + in + run x test + + let test_concurrent_head_updates x () = + let test repo = + let k i = [ "a"; "b"; "c"; string_of_int i ] in + let v i = Fmt.str "X%d" i in + let* t1 = S.main repo in + let* t2 = S.main repo in + let retry d fn = + let rec aux i = + fn () >>= function + | true -> + [%log.debug "%d: ok!" d]; + Lwt.return_unit + | false -> + [%log.debug "%d: conflict, retrying (%d)." d i]; + aux (i + 1) + in + aux 1 + in + let write t n = + write (fun i -> + retry i (fun () -> + let* test = S.Head.find t in + let tag = Fmt.str "tmp-%d-%d" n i in + let* m = S.clone ~src:t ~dst:tag in + S.set_exn m ~info:(infof "update") (k i) (v i) >>= fun () -> + let* set = S.Head.find m in + Lwt.pause () >>= fun () -> S.Head.test_and_set t ~test ~set)) + in + let read t = + read + (fun i -> S.get t (k i)) + (fun i -> check S.contents_t (Fmt.str "update: multi %d" i) (v i)) + in + S.set_exn t1 ~info:(infof "update") (k 0) (v 0) >>= fun () -> + perform (write t1 1 5 @ write t2 2 5) >>= fun () -> + perform (read t1 5) >>= fun () -> B.Repo.close repo + in + run x test + + let test_shallow_objects x () = + let test repo = + (* NOTE: A store of type `Irmin.Generic_key.S` does not currently expose + functions for building nodes / commits with non-existent children, due to + the need to have _keys_ for all store pointers. + + A future version of this API may support such operations (e.g. for + constructing Merkle proofs), but until then we must synthesise test keys + by adding test values to the correponding backend stores directly. *) + let contents (s : string) : S.contents_key Lwt.t = + with_contents repo (fun c -> B.Contents.add c s) + in + let node (s : string) : S.node_key Lwt.t = + with_node repo (fun n -> + let* contents = contents s in + let node = B.Node.Val.(add (empty ())) s (normal contents) in + B.Node.add n node) + in + let commit (s : string) : S.commit_key Lwt.t = + with_commit repo (fun c -> + let* node = node s in + let commit = B.Commit.Val.v ~info:(info "") ~node ~parents:[] in + B.Commit.add c commit) + in + let* foo_k = node "foo" in + let* bar_k = node "bar" in + let tree_1 = S.Tree.shallow repo (`Node foo_k) in + let tree_2 = S.Tree.shallow repo (`Node bar_k) in + let* node_3 = + let+ contents_foo = contents "foo" in + S.Backend.Node.Val.of_list + [ + ("foo", `Contents (contents_foo, S.Metadata.default)); + ("bar", `Node bar_k); + ] + in + let tree_3 = S.Tree.of_node (S.of_backend_node repo node_3) in + let* _ = + S.Backend.Repo.batch repo (fun c n _ -> S.save_tree repo c n tree_3) + in + let key_3 = get_node_key (Option.get (S.Tree.key tree_3)) in + let info () = info "shallow" in + let* t = S.main repo in + S.set_tree_exn t [ "1" ] tree_1 ~info >>= fun () -> + S.set_tree_exn t [ "2" ] tree_2 ~info >>= fun () -> + let* h = S.Head.get t in + let* commit_v = + let+ commit_foo = commit "foo" in + S.Backend.Commit.Val.v ~info:(info ()) ~node:key_3 + ~parents:[ S.Commit.key h; commit_foo ] + in + let* commit_key = with_commit repo (fun c -> B.Commit.add c commit_v) in + let commit = S.of_backend_commit repo commit_key commit_v in + S.set_tree_exn t [ "3" ] ~parents:[ commit ] tree_3 ~info >>= fun () -> + let* t1 = S.find_tree t [ "1" ] in + Alcotest.(check (option tree_t)) "shallow tree" (Some tree_1) t1; + B.Repo.close repo + in + run x test + + let test_pre_hash_collisions x () = + let pre_hash_of ty = + let f = Irmin.Type.(pre_hash ty |> unstage) in + fun x -> + let buf = Buffer.create 0 in + f x (Buffer.add_string buf); + Buffer.contents buf + in + let rec add_entries acc = function + | 0 -> Lwt.return acc + | i -> + let s = string_of_int i in + let* acc = S.Tree.add acc [ s ] s in + add_entries acc (i - 1) + in + let equal_hash = Irmin.Type.(equal S.Hash.t |> unstage) in + let test create_tree repo = + let* tree = create_tree () in + let* c = S.Commit.v repo ~info:S.Info.empty ~parents:[] tree in + + let* node_b = + S.Tree.destruct tree + |> (function `Contents _ -> assert false | `Node n -> n) + |> S.to_backend_node + in + let node_ph = pre_hash_of S.Backend.Node.Val.t node_b in + let node_h = S.Backend.Node.Hash.hash node_b in + + let commit_b = S.to_backend_commit c in + let commit_ph = pre_hash_of S.Backend.Commit.Val.t commit_b in + let commit_h = S.Backend.Commit.Hash.hash commit_b in + + let* blob_k = + with_contents repo (fun t -> S.Backend.Contents.add t node_ph) + in + let blob_h = S.Backend.Contents.Key.to_hash blob_k in + if equal_hash node_h blob_h then + Alcotest.failf + "node pre-hash attack succeeded. pre-hash is \"%s\". backend node is \ + %a." + (String.escaped node_ph) + (Irmin.Type.pp S.Backend.Node.Val.t) + node_b; + + let* blob_k = + with_contents repo (fun t -> S.Backend.Contents.add t commit_ph) + in + let blob_h = S.Backend.Contents.Key.to_hash blob_k in + if equal_hash commit_h blob_h then + Alcotest.failf + "commit pre-hash attack succeeded. pre-hash is \"%s\". backend \ + commit is %a." + (String.escaped commit_ph) + (Irmin.Type.pp S.Backend.Commit.Val.t) + commit_b; + + S.Backend.Repo.close repo + in + (* Test collisions with the empty node (and its commit), *) + let* () = run x (test @@ fun () -> S.Tree.empty () |> Lwt.return) in + (* with a length one node, *) + run x (test @@ fun () -> add_entries (S.Tree.empty ()) 1) >>= fun () -> + (* and with a length >256 node (which is the threshold for unstable inodes + in irmin pack). *) + run x (test @@ fun () -> add_entries (S.Tree.empty ()) 260) +end + +let suite' l ?(prefix = "") (_, x) = + let (module S) = Suite.store_generic_key x in + let module T = Make (S) in + (prefix ^ x.name, l) + +let when_ b x = if b then x else [] + +let suite sleep (speed, x) = + let (module S) = Suite.store_generic_key x in + let module Zzz = struct + let sleep = sleep + end in + let module T = Make (S) in + let module T_graph = Store_graph.Make (S) in + let module T_watch = Store_watch.Make (Log) (Zzz) (S) in + let with_tree_enabled = + (* Disabled for flakiness. See https://github.com/mirage/irmin/issues/1090. *) + not + (List.mem ~equal:String.equal (Suite.name x) + [ + "FS"; + "FS.UNIX"; + "GIT"; + "GIT.UNIX"; + "HTTP.FS"; + "HTTP.FS.UNIX"; + "HTTP.GIT"; + "HTTP.GIT.UNIX"; + ]) + in + suite' + ([ + ("High-level operations on trees", speed, T.test_trees x); + ("Basic operations on contents", speed, T.test_contents x); + ("Basic operations on nodes", speed, T.test_nodes x); + ("Basic operations on commits", speed, T.test_commits x); + ("Basic operations on branches", speed, T.test_branches x); + ("Hash operations on trees", speed, T.test_tree_hashes x); + ("Basic merge operations", speed, T.test_simple_merges x); + ("Test merges on tree updates", speed, T.test_merge_outdated_tree x); + ("Tree caches and hashconsing", speed, T.test_tree_caches x); + ("Tree proofs", speed, T.test_proofs x); + ("Complex histories", speed, T.test_history x); + ("Empty stores", speed, T.test_empty x); + ("Backend node manipulation", speed, T.test_backend_nodes x); + ("High-level store operations", speed, T.test_stores x); + ("High-level store merges", speed, T.test_merge x); + ("Unrelated merges", speed, T.test_merge_unrelated x); + ("Low-level concurrency", speed, T.test_concurrent_low x); + ("Concurrent updates", speed, T.test_concurrent_updates x); + ("Concurrent head updates", speed, T.test_concurrent_head_updates x); + ("Concurrent merges", speed, T.test_concurrent_merges x); + ("Shallow objects", speed, T.test_shallow_objects x); + ("Closure with disconnected commits", speed, T.test_closure x); + ("Prehash collisions", speed, T.test_pre_hash_collisions x); + ] + @ when_ x.import_supported + [ + ("Basic operations on slices", speed, T.test_slice x); + ("High-level store synchronisation", speed, T.test_sync x); + ] + @ when_ with_tree_enabled + [ ("with_tree strategies", speed, T.test_with_tree x) ] + @ List.map (fun (n, test) -> ("Graph." ^ n, speed, test x)) T_graph.tests + @ List.map (fun (n, test) -> ("Watch." ^ n, speed, test x)) T_watch.tests) + (speed, x) + +let slow_suite (speed, x) = + let (module S) = Suite.store_generic_key x in + let module T = Make (S) in + suite' ~prefix:"SLOW_" + [ + ("Commit wide node", speed, T.test_commit_wide_node x); + ("Wide nodes", `Slow, T.test_wide_nodes x); + ] + (speed, x) + +let run name ?(slow = false) ?random_seed ~sleep ~misc tl = + let () = + match random_seed with + | Some x -> Random.init x + | None -> Random.self_init () + in + Printexc.record_backtrace true; + (* Ensure that failures occuring in async lwt threads are raised. *) + (Lwt.async_exception_hook := fun exn -> raise exn); + let tl1 = List.map (suite sleep) tl in + let tl1 = if slow then tl1 @ List.map slow_suite tl else tl1 in + Alcotest_lwt.run name (misc @ tl1) diff --git a/vendors/irmin/src/irmin-test/store.mli b/vendors/irmin/src/irmin-test/store.mli new file mode 100644 index 0000000000000000000000000000000000000000..57aeeb89dc4b7e139abb096cc525b1ef1f1f49dd --- /dev/null +++ b/vendors/irmin/src/irmin-test/store.mli @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val run : + string -> + ?slow:bool -> + ?random_seed:int -> + sleep:(float -> unit Lwt.t) -> + misc:unit Alcotest_lwt.test list -> + (Alcotest.speed_level * Common.t) list -> + unit Lwt.t diff --git a/vendors/irmin/src/irmin-test/store_graph.ml b/vendors/irmin/src/irmin-test/store_graph.ml new file mode 100644 index 0000000000000000000000000000000000000000..2d576ea5d6667623135eeee22c135e2c145d8041 --- /dev/null +++ b/vendors/irmin/src/irmin-test/store_graph.ml @@ -0,0 +1,209 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +module Make (S : Generic_key) = struct + include Common.Make_helpers (S) + + let test_iter x () = + let test repo = + let pp_id = Irmin.Type.pp S.Tree.kinded_key_t in + let eq_id = Irmin.Type.(unstage (equal S.Tree.kinded_key_t)) in + let mem k ls = List.exists (fun k' -> eq_id k k') ls in + let visited = ref [] in + let skipped = ref [] in + let rev_order oldest k = + if !visited = [] && not (eq_id k oldest) then + Alcotest.fail "traversal should start with oldest node" + in + let in_order oldest k = + if !visited = [] && eq_id k oldest then + Alcotest.fail "traversal shouldn't start with oldest node" + in + let node k = + if mem (`Node k) !visited then + Alcotest.failf "node %a visited twice" (Irmin.Type.pp B.Node.Key.t) k; + visited := `Node k :: !visited; + Lwt.return_unit + in + let contents ?order k = + let e = `Contents (k, S.Metadata.default) in + if mem e !visited then + Alcotest.failf "contents %a visited twice" + (Irmin.Type.pp B.Contents.Key.t) + k; + (match order with None -> () | Some f -> f e); + visited := e :: !visited; + Lwt.return_unit + in + let test_rev_order ~nodes ~max = + let oldest = List.hd nodes in + let contents = contents ~order:(rev_order oldest) in + let+ () = + Graph.iter (g repo) ~min:[] ~max ~node ~contents ~rev:true () + in + List.iter + (fun k -> + if not (mem k !visited) then + Alcotest.failf "%a should be visited" + (Irmin.Type.pp S.Tree.kinded_key_t) + k) + nodes + in + let test_in_order ~nodes ~max = + let oldest = List.hd nodes in + let contents = contents ~order:(in_order oldest) in + let+ () = + Graph.iter (g repo) ~min:[] ~max ~node ~contents ~rev:false () + in + List.iter + (fun k -> + if not (mem k !visited) then + Alcotest.failf "%a should be visited" pp_id k) + nodes + in + let test_skip ~max ~to_skip ~not_visited = + let skip_node k = + if mem (`Node k) to_skip then ( + skipped := `Node k :: !skipped; + Lwt.return_true) + else Lwt.return_false + in + let+ () = + Graph.iter (g repo) ~min:[] ~max ~node ~contents ~skip_node ~rev:false + () + in + List.iter + (fun k -> + if mem k !visited || not (mem k !skipped) then + Alcotest.failf "%a should be skipped" pp_id k) + to_skip; + List.iter + (fun k -> + if mem k !visited || mem k !skipped then + Alcotest.failf "%a should not be skipped nor visited" pp_id k) + not_visited + in + let test_min_max ~nodes ~min ~max ~not_visited = + Graph.iter (g repo) ~min ~max ~node ~contents ~rev:false () + >|= fun () -> + List.iter + (fun k -> + if mem k not_visited && mem k !visited then + Alcotest.failf "%a should not be visited" pp_id k; + if (not (mem k not_visited)) && not (mem k !visited) then + Alcotest.failf "%a should not be visited" pp_id k) + nodes + in + let test1 () = + let* foo = with_contents repo (fun c -> B.Contents.add c "foo") in + let foo_k = (foo, S.Metadata.default) in + let* k1 = with_node repo (fun g -> Graph.v g [ ("b", normal foo) ]) in + let* k2 = with_node repo (fun g -> Graph.v g [ ("a", `Node k1) ]) in + let* k3 = with_node repo (fun g -> Graph.v g [ ("c", `Node k1) ]) in + let nodes = [ `Contents foo_k; `Node k1; `Node k2; `Node k3 ] in + visited := []; + test_rev_order ~nodes ~max:[ k2; k3 ] >>= fun () -> + visited := []; + test_in_order ~nodes ~max:[ k2; k3 ] >>= fun () -> + visited := []; + skipped := []; + test_skip ~max:[ k2; k3 ] ~to_skip:[ `Node k1 ] ~not_visited:[] + >>= fun () -> + visited := []; + let* () = + test_min_max ~nodes ~min:[ k1 ] ~max:[ k2 ] + ~not_visited:[ `Contents foo_k; `Node k3 ] + in + visited := []; + test_min_max ~nodes ~min:[ k2; k3 ] ~max:[ k2; k3 ] + ~not_visited:[ `Contents foo_k; `Node k1 ] + in + let test2 () = + (* Graph.iter requires a node as max, we cannot test a graph with only + contents. *) + let* foo = with_contents repo (fun c -> B.Contents.add c "foo") in + let foo_k = (foo, S.Metadata.default) in + let* k1 = with_node repo (fun g -> Graph.v g [ ("b", normal foo) ]) in + visited := []; + test_rev_order ~nodes:[ `Contents foo_k; `Node k1 ] ~max:[ k1 ] + >>= fun () -> + visited := []; + skipped := []; + test_skip ~max:[ k1 ] + ~to_skip:[ `Node k1 ] + ~not_visited:[ `Contents foo_k ] + in + let test3 () = + let* foo = with_contents repo (fun c -> B.Contents.add c "foo") in + let foo_k = (foo, S.Metadata.default) in + let* kb1 = with_node repo (fun g -> Graph.v g [ ("b1", normal foo) ]) in + let* ka1 = with_node repo (fun g -> Graph.v g [ ("a1", `Node kb1) ]) in + let* ka2 = with_node repo (fun g -> Graph.v g [ ("a2", `Node kb1) ]) in + let* kb2 = with_node repo (fun g -> Graph.v g [ ("b2", normal foo) ]) in + let* kc = + with_node repo (fun g -> + Graph.v g + [ ("c1", `Node ka1); ("c2", `Node ka2); ("c3", `Node kb2) ]) + in + let nodes = + [ + `Contents foo_k; + `Node kb1; + `Node ka1; + `Node ka2; + `Node kb2; + `Node kc; + ] + in + visited := []; + test_rev_order ~nodes ~max:[ kc ] >>= fun () -> + visited := []; + test_in_order ~nodes ~max:[ kc ] >>= fun () -> + visited := []; + skipped := []; + let* () = + test_skip ~max:[ kc ] + ~to_skip:[ `Node ka1; `Node ka2 ] + ~not_visited:[ `Node kb1 ] + in + visited := []; + skipped := []; + let* () = + test_skip ~max:[ kc ] + ~to_skip:[ `Node ka1; `Node ka2; `Node kb2 ] + ~not_visited:[ `Node kb1; `Contents foo_k ] + in + visited := []; + let* () = + test_min_max ~nodes ~min:[ kb1 ] ~max:[ ka1 ] + ~not_visited:[ `Contents foo_k; `Node ka2; `Node kb2; `Node kc ] + in + visited := []; + test_min_max ~nodes ~min:[ kc ] ~max:[ kc ] + ~not_visited: + [ `Contents foo_k; `Node kb1; `Node ka1; `Node ka2; `Node kb2 ] + in + test1 () >>= fun () -> + test2 () >>= fun () -> + test3 () >>= fun () -> B.Repo.close repo + in + run x test + + let tests = [ ("Iter", test_iter) ] +end diff --git a/vendors/irmin/src/irmin-test/store_graph.mli b/vendors/irmin/src/irmin-test/store_graph.mli new file mode 100644 index 0000000000000000000000000000000000000000..5e5cf9415ee4a639b7b1aa4b863a13ccaefff8a7 --- /dev/null +++ b/vendors/irmin/src/irmin-test/store_graph.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make : Common.Store_tests diff --git a/vendors/irmin/src/irmin-test/store_watch.ml b/vendors/irmin/src/irmin-test/store_watch.ml new file mode 100644 index 0000000000000000000000000000000000000000..eb14afc329d45d706ecc630b72f73123daf360bc --- /dev/null +++ b/vendors/irmin/src/irmin-test/store_watch.ml @@ -0,0 +1,379 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +module type Sleep = sig + val sleep : float -> unit Lwt.t +end + +module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct + include Common.Make_helpers (S) + + let sleep ?(sleep_t = 0.01) () = + let sleep_t = min sleep_t 1. in + Lwt.pause () >>= fun () -> Zzz.sleep sleep_t + + let now_s () = Mtime.Span.to_s (Mtime_clock.elapsed ()) + + (* Re-apply [f] at intervals of [sleep_t] while [f] raises exceptions and + [while_ ()] holds. *) + let retry ?(timeout = 15.) ?(sleep_t = 0.) ~while_ fn = + let sleep_t = max sleep_t 0.001 in + let t = now_s () in + let str i = Fmt.str "%d, %.3fs" i (now_s () -. t) in + let rec aux i = + if now_s () -. t > timeout || not (while_ ()) then fn (str i); + try + fn (str i); + Lwt.return_unit + with ex -> + [%log.debug "retry ex: %s" (Printexc.to_string ex)]; + let sleep_t = sleep_t *. (1. +. (float i ** 2.)) in + sleep ~sleep_t () >>= fun () -> + [%log.debug "Test.retry %s" (str i)]; + aux (i + 1) + in + aux 0 + + let test_watch_exn x () = + let test repo = + let* t = S.main repo in + let* h = S.Head.find t in + let key = [ "a" ] in + let v1 = "bar" in + let v2 = "foo" in + let r = ref 0 in + let eq = Irmin.Type.(unstage (equal (Irmin.Diff.t (S.commit_t repo)))) in + let old_head = ref h in + let check x = + let+ h2 = S.Head.get t in + match !old_head with + | None -> if eq (`Added h2) x then incr r + | Some h -> if eq (`Updated (h, h2)) x then incr r + in + let* u = + S.watch ?init:h t (fun v -> check v >|= fun () -> failwith "test") + in + let* v = + S.watch ?init:h t (fun v -> check v >>= fun () -> Lwt.fail_with "test") + in + let* w = S.watch ?init:h t (fun v -> check v) in + S.set_exn t ~info:(infof "update") key v1 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 3) + (fun n -> Alcotest.(check int) ("watch 1 " ^ n) 3 !r) + in + let* h = S.Head.find t in + old_head := h; + S.set_exn t ~info:(infof "update") key v2 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 6) + (fun n -> Alcotest.(check int) ("watch 2 " ^ n) 6 !r) + in + S.unwatch u >>= fun () -> + S.unwatch v >>= fun () -> + S.unwatch w >>= fun () -> + let* h = S.Head.get t in + old_head := Some h; + let* u = + S.watch_key ~init:h t key (fun _ -> + incr r; + failwith "test") + in + let* v = + S.watch_key ~init:h t key (fun _ -> + incr r; + Lwt.fail_with "test") + in + let* w = + S.watch_key ~init:h t key (fun _ -> + incr r; + Lwt.return_unit) + in + S.set_exn t ~info:(infof "update") key v1 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 9) + (fun n -> Alcotest.(check int) ("watch 3 " ^ n) 9 !r) + in + S.set_exn t ~info:(infof "update") key v2 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 12) + (fun n -> Alcotest.(check int) ("watch 4 " ^ n) 12 !r) + in + S.unwatch u >>= fun () -> + S.unwatch v >>= fun () -> + S.unwatch w >>= fun () -> + Alcotest.(check unit) "ok!" () (); + B.Repo.close repo + in + run x test + + let test_watches x () = + let pp_w ppf (p, w) = Fmt.pf ppf "%d/%d" p w in + let pp_s ppf = function + | None -> Fmt.string ppf "*" + | Some w -> pp_w ppf (w ()) + in + let check_workers msg p w = + match x.stats with + | None -> Lwt.return_unit + | Some stats -> + retry + ~while_:(fun _ -> true) + (fun s -> + let got = stats () in + let exp = (p, w) in + let msg = Fmt.str "workers: %s %a (%s)" msg pp_w got s in + if got = exp then line msg + else ( + [%log.debug + "check-worker: expected %a, got %a" pp_w exp pp_w got]; + Alcotest.failf "%s: %a / %a" msg pp_w got pp_w exp)) + in + let module State = struct + type t = { + mutable adds : int; + mutable updates : int; + mutable removes : int; + } + + let pp ppf { adds; updates; removes } = + Fmt.pf ppf "{ adds=%d; updates=%d; removes=%d }" adds updates removes + + let empty () = { adds = 0; updates = 0; removes = 0 } + + let add t = + [%log.debug "add %a" pp t]; + t.adds <- t.adds + 1 + + let update t = + [%log.debug "update %a" pp t]; + t.updates <- t.updates + 1 + + let remove t = + [%log.debug "remove %a" pp t]; + t.removes <- t.removes + 1 + + let pretty ppf t = Fmt.pf ppf "%d/%d/%d" t.adds t.updates t.removes + let xpp ppf (a, u, r) = Fmt.pf ppf "%d/%d/%d" a u r + let xadd (a, u, r) = (a + 1, u, r) + let xupdate (a, u, r) = (a, u + 1, r) + let xremove (a, u, r) = (a, u, r + 1) + + let less_than a b = + a.adds <= b.adds + && a.updates <= b.updates + && a.removes <= b.removes + && not (a = b) + + let check ?sleep_t msg (p, w) (a_adds, a_updates, a_removes) b = + let a = { adds = a_adds; updates = a_updates; removes = a_removes } in + check_workers msg p w >>= fun () -> + retry ?sleep_t + ~while_:(fun () -> less_than b a (* While [b] converges toward [a] *)) + (fun s -> + let msg = Fmt.str "state: %s (%s)" msg s in + if a = b then line msg + else Alcotest.failf "%s: %a / %a" msg pp a pp b) + + let process ?sleep_t t head = + let* () = + match sleep_t with None -> Lwt.return_unit | Some s -> Zzz.sleep s + in + let () = + match head with + | `Added _ -> add t + | `Updated _ -> update t + | `Removed _ -> remove t + in + Lwt.return_unit + + let apply msg state kind fn ?(first = false) on s n = + let msg mode n w s = + let kind = + match kind with + | `Add -> "add" + | `Update -> "update" + | `Remove -> "remove" + in + let mode = + match mode with `Pre -> "[pre-condition]" | `Post -> "" + in + Fmt.str "%s %s %s %d on=%b expected=%a:%a current=%a:%a" mode msg kind + n on xpp s pp_w w pretty state pp_s x.stats + in + let check mode n w s = check (msg mode n w s) w s state in + let incr = + match kind with + | `Add -> xadd + | `Update -> xupdate + | `Remove -> xremove + in + let rec aux pre = function + | 0 -> Lwt.return_unit + | i -> + let pre_w = + if on then (1, if i = n && first then 0 else 1) else (0, 0) + in + let post_w = if on then (1, 1) else (0, 0) in + let post = if on then incr pre else pre in + (* check pre-condition *) + check `Pre (n - i) pre_w pre >>= fun () -> + [%log.debug "[waiting for] %s" (msg `Post (n - i) post_w post)]; + fn (n - i) >>= fun () -> + (* check post-condition *) + check `Post (n - i) post_w post >>= fun () -> aux post (i - 1) + in + aux s n + end in + let test repo1 = + let* t1 = S.main repo1 in + let* repo = S.Repo.v x.config in + let* t2 = S.main repo in + [%log.debug "WATCH"]; + let state = State.empty () in + let sleep_t = 0.02 in + let process = State.process ~sleep_t state in + let stops_0 = ref [] in + let stops_1 = ref [] in + let rec watch = function + | 0 -> Lwt.return_unit + | n -> + let t = if n mod 2 = 0 then t1 else t2 in + let* s = S.watch t process in + if n mod 2 = 0 then stops_0 := s :: !stops_0 + else stops_1 := s :: !stops_1; + watch (n - 1) + in + let v1 = "X1" in + let v2 = "X2" in + S.set_exn t1 ~info:(infof "update") [ "a"; "b" ] v1 >>= fun () -> + S.Branch.remove repo1 S.Branch.main >>= fun () -> + State.check "init" (0, 0) (0, 0, 0) state >>= fun () -> + watch 100 >>= fun () -> + State.check "watches on" (1, 0) (0, 0, 0) state >>= fun () -> + S.set_exn t1 ~info:(infof "update") [ "a"; "b" ] v1 >>= fun () -> + State.check "watches adds" (1, 1) (100, 0, 0) state >>= fun () -> + S.set_exn t2 ~info:(infof "update") [ "a"; "c" ] v1 >>= fun () -> + State.check "watches updates" (1, 1) (100, 100, 0) state >>= fun () -> + S.Branch.remove repo S.Branch.main >>= fun () -> + State.check "watches removes" (1, 1) (100, 100, 100) state >>= fun () -> + Lwt_list.iter_s (fun f -> S.unwatch f) !stops_0 >>= fun () -> + S.set_exn t2 ~info:(infof "update") [ "a" ] v1 >>= fun () -> + State.check "watches half off" (1, 1) (150, 100, 100) state >>= fun () -> + Lwt_list.iter_s (fun f -> S.unwatch f) !stops_1 >>= fun () -> + S.set_exn t1 ~info:(infof "update") [ "a" ] v2 >>= fun () -> + State.check "watches off" (0, 0) (150, 100, 100) state >>= fun () -> + [%log.debug "WATCH-ALL"]; + let state = State.empty () in + let* head = r1 ~repo in + let add = + State.apply "branch-watch-all" state `Add (fun n -> + let tag = Fmt.str "t%d" n in + S.Branch.set repo tag head) + in + let remove = + State.apply "branch-watch-all" state `Remove (fun n -> + let tag = Fmt.str "t%d" n in + S.Branch.remove repo tag) + in + let* main = S.Branch.get repo "main" in + let* u = + S.Branch.watch_all + ~init:[ ("main", main) ] + repo + (fun _ -> State.process state) + in + add true (0, 0, 0) 10 ~first:true >>= fun () -> + remove true (10, 0, 0) 5 >>= fun () -> + S.unwatch u >>= fun () -> + add false (10, 0, 5) 4 >>= fun () -> + remove false (10, 0, 5) 4 >>= fun () -> + [%log.debug "WATCH-KEY"]; + let state = State.empty () in + let path1 = [ "a"; "b"; "c" ] in + let path2 = [ "a"; "d" ] in + let path3 = [ "a"; "b"; "d" ] in + let add = + State.apply "branch-key" state `Add (fun _ -> + let v = "" in + S.set_exn t1 ~info:(infof "set1") path1 v >>= fun () -> + S.set_exn t1 ~info:(infof "set2") path2 v >>= fun () -> + S.set_exn t1 ~info:(infof "set3") path3 v >>= fun () -> + Lwt.return_unit) + in + let update = + State.apply "branch-key" state `Update (fun n -> + let v = string_of_int n in + S.set_exn t2 ~info:(infof "update1") path1 v >>= fun () -> + S.set_exn t2 ~info:(infof "update2") path2 v >>= fun () -> + S.set_exn t2 ~info:(infof "update3") path3 v >>= fun () -> + Lwt.return_unit) + in + let remove = + State.apply "branch-key" state `Remove (fun _ -> + S.remove_exn t1 ~info:(infof "remove1") path1 >>= fun () -> + S.remove_exn t1 ~info:(infof "remove2") path2 >>= fun () -> + S.remove_exn t1 ~info:(infof "remove3") path3 >>= fun () -> + Lwt.return_unit) + in + S.remove_exn t1 ~info:(infof "clean") [] >>= fun () -> + let* init = S.Head.get t1 in + let* u = S.watch_key t1 ~init path1 (State.process state) in + add true (0, 0, 0) 1 ~first:true >>= fun () -> + update true (1, 0, 0) 10 >>= fun () -> + remove true (1, 10, 0) 1 >>= fun () -> + S.unwatch u >>= fun () -> + add false (1, 10, 1) 3 >>= fun () -> + update false (1, 10, 1) 5 >>= fun () -> + remove false (1, 10, 1) 4 >>= fun () -> + [%log.debug "WATCH-MORE"]; + let state = State.empty () in + let update = + State.apply "watch-more" state `Update (fun n -> + let v = string_of_int n in + let path1 = [ "a"; "b"; "c"; string_of_int n; "1" ] in + let path2 = [ "a"; "x"; "c"; string_of_int n; "1" ] in + let path3 = [ "a"; "y"; "c"; string_of_int n; "1" ] in + S.set_exn t2 ~info:(infof "update1") path1 v >>= fun () -> + S.set_exn t2 ~info:(infof "update2") path2 v >>= fun () -> + S.set_exn t2 ~info:(infof "update3") path3 v >>= fun () -> + Lwt.return_unit) + in + S.remove_exn t1 ~info:(infof "remove") [ "a" ] >>= fun () -> + S.set_exn t1 ~info:(infof "prepare") [ "a"; "b"; "c" ] "" >>= fun () -> + let* h = S.Head.get t1 in + let* u = S.watch_key t2 ~init:h [ "a"; "b" ] (State.process state) in + update true (0, 0, 0) 10 ~first:true >>= fun () -> + S.unwatch u >>= fun () -> + update false (0, 10, 0) 10 >>= fun () -> + B.Repo.close repo >>= fun () -> B.Repo.close repo1 + in + run x test + + let tests = + (* [test_watches] has been disabled for being flaky. + TODO: work out why, fix it, and re-enable it. + See https://github.com/mirage/irmin/issues/1447. *) + let _ = ("Basic operations", test_watches) in + [ ("Callbacks and exceptions", test_watch_exn) ] +end diff --git a/vendors/irmin/src/irmin-test/store_watch.mli b/vendors/irmin/src/irmin-test/store_watch.mli new file mode 100644 index 0000000000000000000000000000000000000000..52f253c7bb3cf8384cb27d21ca57ad708b1df81a --- /dev/null +++ b/vendors/irmin/src/irmin-test/store_watch.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (_ : Logs.LOG) (_ : Common.Sleep) : Common.Store_tests diff --git a/vendors/irmin/src/irmin-tezos/dune b/vendors/irmin/src/irmin-tezos/dune new file mode 100644 index 0000000000000000000000000000000000000000..93d3e85228c8a949bcc1e519f5ecdb9805065c08 --- /dev/null +++ b/vendors/irmin/src/irmin-tezos/dune @@ -0,0 +1,6 @@ +(library + (name irmin_tezos) + (public_name irmin-tezos) + (libraries tezos-base58 digestif fmt irmin irmin-pack irmin-pack.unix) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin-tezos/irmin_tezos.ml b/vendors/irmin/src/irmin-tezos/irmin_tezos.ml new file mode 100644 index 0000000000000000000000000000000000000000..2b52362bdfadda6cb96fdfb8d3abe42917827f73 --- /dev/null +++ b/vendors/irmin/src/irmin-tezos/irmin_tezos.ml @@ -0,0 +1,28 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Schema = Schema + +module Conf = struct + let entries = 32 + let stable_hash = 256 + let contents_length_header = Some `Varint + let inode_child_order = `Seeded_hash + let forbid_empty_dir_persistence = true +end + +module Maker = Irmin_pack_unix.Maker (Conf) +module Store = Maker.Make (Schema) diff --git a/vendors/irmin/src/irmin-tezos/irmin_tezos.mli b/vendors/irmin/src/irmin-tezos/irmin_tezos.mli new file mode 100644 index 0000000000000000000000000000000000000000..e12662bef4672ebecb872eeb5dbd6144cb16be9f --- /dev/null +++ b/vendors/irmin/src/irmin-tezos/irmin_tezos.mli @@ -0,0 +1,31 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Schema = Schema +module Conf : Irmin_pack.Conf.S + +module Store : + Irmin_pack.S + with type Schema.Hash.t = Schema.Hash.t + and type Schema.Branch.t = Schema.Branch.t + and type Schema.Metadata.t = Schema.Metadata.t + and type Schema.Path.t = Schema.Path.t + and type Schema.Path.step = Schema.Path.step + and type Schema.Contents.t = Schema.Contents.t + and type Backend.Remote.endpoint = unit + and type contents_key = Schema.Hash.t Irmin_pack.Pack_key.t + and type node_key = Schema.Hash.t Irmin_pack.Pack_key.t + and type commit_key = Schema.Hash.t Irmin_pack.Pack_key.t diff --git a/vendors/irmin/src/irmin-tezos/schema.ml b/vendors/irmin/src/irmin-tezos/schema.ml new file mode 100644 index 0000000000000000000000000000000000000000..0ecb2b424988de21c686c234085ccd6343c71724 --- /dev/null +++ b/vendors/irmin/src/irmin-tezos/schema.ml @@ -0,0 +1,151 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Path = Irmin.Path.String_list +module Metadata = Irmin.Metadata.None +module Branch = Irmin.Branch.String + +module Hash : Irmin.Hash.S = struct + module H = Digestif.Make_BLAKE2B (struct + let digest_size = 32 + end) + + type t = H.t + + let prefix = "\079\199" (* Co(52) *) + + let pp ppf t = + let s = H.to_raw_string t in + Tezos_base58.pp ppf (Tezos_base58.encode ~prefix s) + + let of_b58 : string -> (t, [ `Msg of string ]) result = + fun x -> + match Tezos_base58.decode ~prefix (Base58 x) with + | Some x -> Ok (H.of_raw_string x) + | None -> Error (`Msg "Failed to read b58check_encoding data") + + let short_hash_string = Repr.(unstage (short_hash string)) + let short_hash ?seed t = short_hash_string ?seed (H.to_raw_string t) + + let t : t Repr.t = + Repr.map ~pp ~of_string:of_b58 + Repr.(string_of (`Fixed H.digest_size)) + ~short_hash H.of_raw_string H.to_raw_string + + let short_hash_string = short_hash_string ?seed:None + let short_hash t = short_hash_string (H.to_raw_string t) + let hash_size = H.digest_size + + let short_hash_substring t ~off = + short_hash_string (Bigstringaf.substring t ~off ~len:hash_size) + + let hash = H.digesti_string + let to_raw_string = H.to_raw_string + let unsafe_of_raw_string = H.of_raw_string +end + +module Info = Irmin.Info.Default + +module Node + (Contents_key : Irmin.Key.S with type hash = Hash.t) + (Node_key : Irmin.Key.S with type hash = Hash.t) = +struct + module M = + Irmin.Node.Generic_key.Make (Hash) (Path) (Metadata) (Contents_key) + (Node_key) + + (* [V1] is only used to compute preimage hashes. [assert false] + statements should be unreachable.*) + module V1 : sig + val pre_hash : M.t -> (string -> unit) -> unit + end = struct + module Hash = Irmin.Hash.V1 (Hash) + + type entry = string * M.value + + (* Irmin 1.4 uses int8 to store filename lengths. + + Irmin 2 use a variable-size encoding for strings; this is using int8 + for strings of size stricly less than 128 (e.g. 2^7) which happen to + be the case for all filenames ever produced by Irmin 1.4. *) + let step_t = Irmin.Type.string + + let metadata_t = + let some = "\255\000\000\000\000\000\000\000" in + let none = "\000\000\000\000\000\000\000\000" in + Irmin.Type.(map (string_of (`Fixed 8))) + (fun _ -> assert false) + (function Some _ -> some | None -> none) + + let metadata_of_entry (_, t) = + match t with `Node _ -> None | `Contents (_, m) -> Some m + + let hash_of_entry (_, t) = + match t with + | `Node h -> Node_key.to_hash h + | `Contents (h, _) -> Contents_key.to_hash h + + (* Irmin 1.4 uses int64 to store list lengths *) + let entry_t : entry Irmin.Type.t = + let open Irmin.Type in + record "Tree.entry" (fun _ _ _ -> assert false) + |+ field "kind" metadata_t metadata_of_entry + |+ field "name" step_t fst + |+ field "hash" Hash.t hash_of_entry + |> sealr + + let entries_t : entry list Irmin.Type.t = + Irmin.Type.(list ~len:`Int64 entry_t) + + let pre_hash_entries = Irmin.Type.(unstage (pre_hash entries_t)) + let compare_entry (x, _) (y, _) = String.compare x y + let step_to_string = Irmin.Type.(unstage (to_bin_string Path.step_t)) + let str_key (k, v) = (step_to_string k, v) + + let pre_hash t = + M.list t + |> List.map str_key + |> List.fast_sort compare_entry + |> pre_hash_entries + end + + include M + + let t = Irmin.Type.(like t ~pre_hash:V1.pre_hash) +end + +module Commit + (Node_key : Irmin.Key.S with type hash = Hash.t) + (Commit_key : Irmin.Key.S with type hash = Hash.t) = +struct + module M = Irmin.Commit.Generic_key.Make (Hash) (Node_key) (Commit_key) + module V1 = Irmin.Commit.V1.Make (Hash) (M) + include M + + let pre_hash_v1_t = Irmin.Type.(unstage (pre_hash V1.t)) + let pre_hash_v1 t = pre_hash_v1_t (V1.import t) + let t = Irmin.Type.(like t ~pre_hash:pre_hash_v1) +end + +module Contents = struct + type t = bytes + + let ty = Irmin.Type.(pair (bytes_of `Int64) unit) + let pre_hash_ty = Irmin.Type.(unstage (pre_hash ty)) + let pre_hash_v1 x = pre_hash_ty (x, ()) + let t = Irmin.Type.(like bytes ~pre_hash:pre_hash_v1) + let merge = Irmin.Merge.(idempotent (Irmin.Type.option t)) +end diff --git a/vendors/irmin/src/irmin-tezos/schema.mli b/vendors/irmin/src/irmin-tezos/schema.mli new file mode 100644 index 0000000000000000000000000000000000000000..b1d7246cb95fd9aec05496514590b90ad40ff698 --- /dev/null +++ b/vendors/irmin/src/irmin-tezos/schema.mli @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include + Irmin.Schema.Extended + with type Contents.t = bytes + and type Metadata.t = unit + and type Path.t = string list + and type Path.step = string + and type Branch.t = string + and module Info = Irmin.Info.Default diff --git a/vendors/irmin/src/irmin/append_only.ml b/vendors/irmin/src/irmin/append_only.ml new file mode 100644 index 0000000000000000000000000000000000000000..2075b21c1c46c77b588b474c35a11fab059f0dee --- /dev/null +++ b/vendors/irmin/src/irmin/append_only.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Append_only_intf diff --git a/vendors/irmin/src/irmin/append_only.mli b/vendors/irmin/src/irmin/append_only.mli new file mode 100644 index 0000000000000000000000000000000000000000..0356a7e81971ccbeaa420f25a37f63ceef6d80a4 --- /dev/null +++ b/vendors/irmin/src/irmin/append_only.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Append_only_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/append_only_intf.ml b/vendors/irmin/src/irmin/append_only_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..b5d318d4aae5d03e01fe5a5d26687d4402b58496 --- /dev/null +++ b/vendors/irmin/src/irmin/append_only_intf.ml @@ -0,0 +1,51 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +open Store_properties + +module type S = sig + (** {1 Append-only stores} + + Append-only stores are store where it is possible to read and add new + values. *) + + include Read_only.S + (** @inline *) + + val add : [> write ] t -> key -> value -> unit Lwt.t + (** Write the contents of a value to the store. *) + + include Closeable with type 'a t := 'a t + (** @inline *) + + include Batch with type 'a t := 'a t + (** @inline *) +end + +module Append_only_is_a_read_only (X : S) : Read_only.S = X + +module type Maker = functor (K : Type.S) (V : Type.S) -> sig + include S with type key = K.t and type value = V.t + + include Of_config with type 'a t := 'a t + (** @inline *) +end + +module type Sigs = sig + module type S = S + module type Maker = Maker +end diff --git a/vendors/irmin/src/irmin/atomic_write.ml b/vendors/irmin/src/irmin/atomic_write.ml new file mode 100644 index 0000000000000000000000000000000000000000..e111fa5a0f23cea7667c95b16813c91a5fdede2a --- /dev/null +++ b/vendors/irmin/src/irmin/atomic_write.ml @@ -0,0 +1,81 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +include Atomic_write_intf + +module Check_closed (Make_atomic_write : Maker) (K : Type.S) (V : Type.S) = +struct + module S = Make_atomic_write (K) (V) + + type t = { closed : bool ref; t : S.t } + type key = S.key + type value = S.value + + let check_not_closed t = if !(t.closed) then raise Store_properties.Closed + + let mem t k = + check_not_closed t; + S.mem t.t k + + let find t k = + check_not_closed t; + S.find t.t k + + let set t k v = + check_not_closed t; + S.set t.t k v + + let test_and_set t k ~test ~set = + check_not_closed t; + S.test_and_set t.t k ~test ~set + + let remove t k = + check_not_closed t; + S.remove t.t k + + let list t = + check_not_closed t; + S.list t.t + + type watch = S.watch + + let watch t ?init f = + check_not_closed t; + S.watch t.t ?init f + + let watch_key t k ?init f = + check_not_closed t; + S.watch_key t.t k ?init f + + let unwatch t w = + check_not_closed t; + S.unwatch t.t w + + let v conf = + let+ t = S.v conf in + { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) + + let clear t = + check_not_closed t; + S.clear t.t +end diff --git a/vendors/irmin/src/irmin/atomic_write.mli b/vendors/irmin/src/irmin/atomic_write.mli new file mode 100644 index 0000000000000000000000000000000000000000..f42c7e8c8f5b3524de55d42484b19f9a44f4e0df --- /dev/null +++ b/vendors/irmin/src/irmin/atomic_write.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Atomic_write_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/atomic_write_intf.ml b/vendors/irmin/src/irmin/atomic_write_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..77299105f6b98e9a319a7aba746d29fa4432f714 --- /dev/null +++ b/vendors/irmin/src/irmin/atomic_write_intf.ml @@ -0,0 +1,94 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Store_properties + +type 'a diff = 'a Diff.t + +module type S = sig + (** {1 Atomic write stores} + + Atomic-write stores are stores where it is possible to read, update and + remove elements, with atomically guarantees. *) + + type t + (** The type for atomic-write backend stores. *) + + include Read_only.S with type _ t := t + (** @inline *) + + val set : t -> key -> value -> unit Lwt.t + (** [set t k v] replaces the contents of [k] by [v] in [t]. If [k] is not + already defined in [t], create a fresh binding. Raise [Invalid_argument] + if [k] is the {{!Irmin.Path.S.empty} empty path}. *) + + val test_and_set : + t -> key -> test:value option -> set:value option -> bool Lwt.t + (** [test_and_set t key ~test ~set] sets [key] to [set] only if the current + value of [key] is [test] and in that case returns [true]. If the current + value of [key] is different, it returns [false]. [None] means that the + value does not have to exist or is removed. + + {b Note:} The operation is guaranteed to be atomic. *) + + val remove : t -> key -> unit Lwt.t + (** [remove t k] remove the key [k] in [t]. *) + + val list : t -> key list Lwt.t + (** [list t] it the list of keys in [t]. *) + + type watch + (** The type of watch handlers. *) + + val watch : + t -> + ?init:(key * value) list -> + (key -> value diff -> unit Lwt.t) -> + watch Lwt.t + (** [watch t ?init f] adds [f] to the list of [t]'s watch handlers and returns + the watch handler to be used with {!unwatch}. [init] is the optional + initial values. It is more efficient to use {!watch_key} to watch only a + single given key.*) + + val watch_key : + t -> key -> ?init:value -> (value diff -> unit Lwt.t) -> watch Lwt.t + (** [watch_key t k ?init f] adds [f] to the list of [t]'s watch handlers for + the key [k] and returns the watch handler to be used with {!unwatch}. + [init] is the optional initial value of the key. *) + + val unwatch : t -> watch -> unit Lwt.t + (** [unwatch t w] removes [w] from [t]'s watch handlers. *) + + include Clearable with type _ t := t + (** @inline *) + + include Closeable with type _ t := t + (** @inline *) +end + +module type Maker = functor (K : Type.S) (V : Type.S) -> sig + include S with type key = K.t and type value = V.t + + include Of_config with type _ t := t + (** @inline *) +end + +module type Sigs = sig + module type S = S + module type Maker = Maker + + module Check_closed (M : Maker) : Maker +end diff --git a/vendors/irmin/src/irmin/backend.ml b/vendors/irmin/src/irmin/backend.ml new file mode 100644 index 0000000000000000000000000000000000000000..4b9f981b7f90f5669eb7b9248d8ce85a35b386e6 --- /dev/null +++ b/vendors/irmin/src/irmin/backend.ml @@ -0,0 +1,119 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Store_properties + +open struct + module type Node_portable = Node.Portable.S + module type Commit_portable = Commit.Portable.S +end + +(** [S] is what a backend must define in order to be made an irmin store. *) +module type S = sig + module Schema : Schema.S + (** A store schema, meant to be provided by the user. *) + + module Hash : Hash.S with type t = Schema.Hash.t + (** Hashing implementation. *) + + (** A contents store. *) + module Contents : + Contents.Store with type hash = Hash.t and type value = Schema.Contents.t + + (** A node store. *) + module Node : + Node.Store + with type hash = Hash.t + and type Val.contents_key = Contents.key + and module Path = Schema.Path + and module Metadata = Schema.Metadata + + (** A node abstraction that is portable from different repos. Similar to + [Node.Val]. *) + module Node_portable : + Node_portable + with type node := Node.value + and type hash := Hash.t + and type metadata := Schema.Metadata.t + and type step := Schema.Path.step + + (** A commit store. *) + module Commit : + Commit.Store + with type hash = Hash.t + and type Val.node_key = Node.key + and module Info = Schema.Info + + (** A commit abstraction that is portable from different repos. Similar to + [Commit.Val]. *) + module Commit_portable : + Commit_portable + with type commit := Commit.value + and type hash := Hash.t + and module Info = Schema.Info + + (** A branch store. *) + module Branch : + Branch.Store with type key = Schema.Branch.t and type value = Commit.key + + (** A slice abstraction. *) + module Slice : + Slice.S + with type contents = Contents.hash * Contents.value + and type node = Node.hash * Node.value + and type commit = Commit.hash * Commit.value + + (** A repo abstraction. *) + module Repo : sig + type t + + (** Repo opening and closing functions *) + + include Of_config with type _ t := t + (** @inline *) + + include Closeable with type _ t := t + (** @inline *) + + (** Getters from repo to backend store in ro mode *) + + val contents_t : t -> read Contents.t + val node_t : t -> read Node.t + val commit_t : t -> read Commit.t + val config : t -> Conf.t + + val batch : + t -> + (read_write Contents.t -> + read_write Node.t -> + read_write Commit.t -> + 'a Lwt.t) -> + 'a Lwt.t + (** A getter from repo to backend stores in rw mode. *) + + val branch_t : t -> Branch.t + (** A branch store getter from repo *) + end + + (** URI-based low-level remote synchronisation. *) + module Remote : sig + include Remote.S with type commit = Commit.key and type branch = Branch.key + + val v : Repo.t -> t Lwt.t + end +end diff --git a/vendors/irmin/src/irmin/branch.ml b/vendors/irmin/src/irmin/branch.ml new file mode 100644 index 0000000000000000000000000000000000000000..9380ad2576ec5e6a882eb2e4690ddfac127d011d --- /dev/null +++ b/vendors/irmin/src/irmin/branch.ml @@ -0,0 +1,36 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Branch_intf + +module String = struct + type t = string + + let t = Type.string + let main = "main" + + let is_valid s = + let ok = ref true in + let n = String.length s in + let i = ref 0 in + while !i < n do + (match s.[!i] with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-' | '_' | '.' -> () + | _ -> ok := false); + incr i + done; + !ok +end diff --git a/vendors/irmin/src/irmin/branch.mli b/vendors/irmin/src/irmin/branch.mli new file mode 100644 index 0000000000000000000000000000000000000000..cb6bbce1440212bf7b3e63473b2adc362f52833a --- /dev/null +++ b/vendors/irmin/src/irmin/branch.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** User-defined branches. *) + +include Branch_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/branch_intf.ml b/vendors/irmin/src/irmin/branch_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..a34a4c28f81a1f1d81fd1bd78862695a13af1d8d --- /dev/null +++ b/vendors/irmin/src/irmin/branch_intf.ml @@ -0,0 +1,62 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Signature for Branches} *) + + type t [@@deriving irmin] + (** The type for branches. *) + + val main : t + (** The name of the main branch. *) + + val is_valid : t -> bool + (** Check if the branch is valid. *) +end + +module Irmin_key = Key + +module type Store = sig + (** {1 Branch Store} *) + + include Atomic_write.S + + module Key : S with type t = key + (** Base functions on keys. *) + + module Val : Irmin_key.S with type t = value + (** Base functions on values. *) +end + +module type Sigs = sig + (** {1 Branches} *) + + module type S = S + (** The signature for branches. Irmin branches are similar to Git branches: + they are used to associated user-defined names to head commits. Branches + have a default value: the {{!Branch.S.main} main} branch. *) + + module String : S with type t = string + (** [String] is an implementation of {{!Branch.S} S} where branches are + strings. The [main] branch is ["main"]. Valid branch names contain only + alpha-numeric characters, [-], [_], [.], and [/]. *) + + module type Store = Store + (** [Store] specifies the signature for branch stores. + + A {i branch store} is a mutable and reactive key / value store, where keys + are branch names created by users and values are keys are head commmits. *) +end diff --git a/vendors/irmin/src/irmin/commit.ml b/vendors/irmin/src/irmin/commit.ml new file mode 100644 index 0000000000000000000000000000000000000000..da05c481734a444eb4864bc8172cf21caeddfadc --- /dev/null +++ b/vendors/irmin/src/irmin/commit.ml @@ -0,0 +1,699 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Commit_intf +open Merge.Infix + +let src = Logs.Src.create "irmin.commit" ~doc:"Irmin commits" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Maker_generic_key (I : Info.S) = struct + module Info = I + + module Make + (H : Type.S) + (N : Key.S with type hash = H.t) + (C : Key.S with type hash = H.t) = + struct + module Info = I + + type hash = H.t [@@deriving irmin ~compare] + type node_key = N.t [@@deriving irmin ~compare] + type commit_key = C.t [@@deriving irmin] + + type t = { node : node_key; parents : commit_key list; info : Info.t } + [@@deriving irmin] + + type t_not_prefixed = t [@@deriving irmin] + + let pre_hash = Type.(unstage (pre_hash t)) + + (* Manually add a prefix to default commits, in order to prevent hash + collision between contents and commits (see + https://github.com/mirage/irmin/issues/1304). + If we only prefix the prehash of contents, (suppose the prefix is "B"), + then we can have a collision with the prehash of a commit (the prehash of + a commit starts with the hash of the root and can start with a "B" - the + prefix of the contents is not enough to prevent the collision). *) + let pre_hash_prefixed x f = + f "C"; + pre_hash x f + + let t = Type.(like t ~pre_hash:pre_hash_prefixed) + let parents t = t.parents + let node t = t.node + let info t = t.info + let compare_commit_key x y = compare_hash (C.to_hash x) (C.to_hash y) + + let v ~info ~node ~parents = + let parents = List.fast_sort compare_commit_key parents in + { node; parents; info } + + module Portable = struct + module Info = I + + type commit = t + + type t = { node : hash; parents : hash list; info : Info.t } + [@@deriving irmin] + + type t_not_prefixed = t [@@deriving irmin] + + let pre_hash = Type.(unstage (pre_hash t)) + + let pre_hash_prefixed x f = + f "C"; + pre_hash x f + + let t = Type.(like t ~pre_hash:pre_hash_prefixed) + + type commit_key = H.t [@@deriving irmin] + type node_key = H.t [@@deriving irmin] + type hash = H.t [@@deriving irmin] + + let parents t = t.parents + let node t = t.node + let info t = t.info + + let v ~info ~node ~parents = + let parents = List.fast_sort compare_hash parents in + { node; parents; info } + + let of_commit : commit -> t = + fun { node; parents; info } -> + let node = N.to_hash node in + let parents = List.map C.to_hash parents in + { node; parents; info } + end + end + + module Make_v2 + (H : Type.S) + (N : Key.S with type hash = H.t) + (C : Key.S with type hash = H.t) = + struct + include Make (H) (N) (C) + + let t = t_not_prefixed_t + + module Portable = struct + include Portable + + let t = t_not_prefixed_t + end + end +end + +module Maker (Info : Info.S) = struct + include Maker_generic_key (Info) + + module Make (H : Type.S) = struct + module Key = Key.Of_hash (H) + include Make (H) (Key) (Key) + end +end + +module Store_generic_key + (I : Info.S) + (N : Node.Store) + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (V : S_generic_key + with type node_key = N.Key.t + and type commit_key = S.Key.t + and type t = S.value + and module Info := I) = +struct + module Node = N + module Val = V + module Key = S.Key + module Hash = Hash.Typed (H) (V) + module Info = I + + type 'a t = 'a N.t * 'a S.t + type key = Key.t [@@deriving irmin ~equal] + type value = S.value + type hash = S.hash + + let add (_, t) = S.add t + let unsafe_add (_, t) = S.unsafe_add t + let mem (_, t) = S.mem t + let index (_, t) = S.index t + let find (_, t) = S.find t + let batch (n, s) f = N.batch n (fun n -> S.batch s (fun s -> f (n, s))) + + let close (n, s) = + let* () = N.close n in + let+ () = S.close s in + () + + let merge_node (t, _) = Merge.f (N.merge t) + let pp_key = Type.pp Key.t + let err_not_found k = Fmt.kstr invalid_arg "Commit.get: %a not found" pp_key k + + let get (_, t) k = + S.find t k >>= function None -> err_not_found k | Some v -> Lwt.return v + + let empty_if_none (n, _) = function + | None -> N.add n (N.Val.empty ()) + | Some node -> Lwt.return node + + let equal_key = Type.(unstage (equal Key.t)) + let equal_opt_keys = Type.(unstage (equal (option Key.t))) + + let merge_commit info t ~old k1 k2 = + [%log.debug "Commit.merge %a %a" pp_key k1 pp_key k2]; + let* v1 = get t k1 in + let* v2 = get t k2 in + if List.mem ~equal:equal_key k1 (Val.parents v2) then Merge.ok k2 + else if List.mem ~equal:equal_key k2 (Val.parents v1) then Merge.ok k1 + else + (* If we get an error while looking the the lca, then we + assume that there is no common ancestor. Maybe we want to + expose this to the user in a more structured way. But maybe + that's too much low-level details. *) + let* old = + old () >>= function + | Error (`Conflict msg) -> + [%log.debug "old: conflict %s" msg]; + Lwt.return_none + | Ok o -> Lwt.return o + in + if equal_opt_keys old (Some k1) then Merge.ok k2 + else if equal_opt_keys old (Some k2) then Merge.ok k1 + else + let old () = + match old with + | None -> Merge.ok None + | Some old -> + let* vold = get t old in + Merge.ok (Some (Some (Val.node vold))) + in + merge_node t ~old (Some (Val.node v1)) (Some (Val.node v2)) + >>=* fun node -> + let* node = empty_if_none t node in + let parents = [ k1; k2 ] in + let commit = Val.v ~node ~parents ~info:(info ()) in + let* key = add t commit in + Merge.ok key + + let merge t ~info = Merge.(option (v Key.t (merge_commit info t))) +end + +module Generic_key = struct + module type S = S_generic_key + module type Maker = Maker_generic_key + + module Maker = Maker_generic_key + module Store = Store_generic_key + include Maker (Info.Default) +end + +module Portable = struct + module Of_commit (X : S) = struct + include X + + let of_commit t = t + end + + module type S = Portable +end + +module Store + (I : Info.S) + (N : Node.Store) + (S : Content_addressable.S with type key = N.key) + (H : Hash.S with type t = S.key) + (V : S with type hash = S.key and type t = S.value and module Info := I) = +struct + include + Store_generic_key (I) (N) (Indexable.Of_content_addressable (H) (S)) (H) (V) + + module Val = struct + include Val + + type hash = H.t [@@deriving irmin] + end +end + +module History (S : Store) = struct + type commit_key = S.Key.t [@@deriving irmin] + type node_key = S.Val.node_key [@@deriving irmin] + type v = S.Val.t [@@deriving irmin] + type info = S.Info.t [@@deriving irmin] + type 'a t = 'a S.t + + let merge t ~info = + let f ~old c1 c2 = + let somify = Merge.map_promise (fun x -> Some x) in + let merge = S.merge t ~info in + Merge.f merge ~old:(somify old) (Some c1) (Some c2) >>=* function + | None -> Merge.conflict "History.merge" + | Some x -> Merge.ok x + in + Merge.v S.Key.t f + + let v t ~node ~parents ~info = + let commit = S.Val.v ~node ~parents ~info in + let+ hash = S.add t commit in + (hash, commit) + + let pp_key = Type.pp S.Key.t + + let parents t c = + [%log.debug "parents %a" pp_key c]; + S.find t c >|= function None -> [] | Some c -> S.Val.parents c + + module U = struct + type t = unit [@@deriving irmin] + end + + module Graph = Object_graph.Make (U) (S.Node.Key) (S.Key) (U) + + let edges t = + [%log.debug "edges"]; + [ `Node (S.Val.node t) ] @ List.map (fun k -> `Commit k) (S.Val.parents t) + + let closure t ~min ~max = + [%log.debug "closure"]; + let pred = function + | `Commit k -> ( S.find t k >|= function Some r -> edges r | None -> []) + | _ -> Lwt.return_nil + in + let min = List.map (fun k -> `Commit k) min in + let max = List.map (fun k -> `Commit k) max in + let+ g = Graph.closure ~pred ~min ~max () in + List.fold_left + (fun acc -> function `Commit k -> k :: acc | _ -> acc) + [] (Graph.vertex g) + + let ignore_lwt _ = Lwt.return_unit + + let iter t ~min ~max ?(commit = ignore_lwt) ?edge + ?(skip = fun _ -> Lwt.return_false) ?(rev = true) () = + let max = List.map (fun x -> `Commit x) max in + let min = List.map (fun x -> `Commit x) min in + let node = function `Commit x -> commit x | _ -> assert false in + let skip = function `Commit x -> skip x | _ -> assert false in + let pred = function + | `Commit k -> parents t k >|= List.map (fun x -> `Commit x) + | _ -> assert false + in + let edge = + Option.map + (fun edge n pred -> + match (n, pred) with + | `Commit src, `Commit dst -> edge src dst + | _ -> assert false) + edge + in + Graph.iter ~pred ~min ~max ~node ?edge ~skip ~rev () + + module K = struct + type t = S.Key.t + + let compare = Type.(unstage (compare S.Key.t)) + let hash k = S.Hash.short_hash (S.Key.to_hash k) + let equal = Type.(unstage (equal S.Key.t)) + end + + module KSet = Set.Make (K) + module KHashtbl = Hashtbl.Make (K) + + let read_parents t commit = + S.find t commit >|= function + | None -> KSet.empty + | Some c -> KSet.of_list (S.Val.parents c) + + let equal_keys = Type.(unstage (equal S.Key.t)) + let str_key k = String.sub (Type.to_string S.Key.t k) 0 4 + let pp_key = Fmt.of_to_string str_key + + let pp_keys ppf keys = + let keys = KSet.elements keys in + Fmt.pf ppf "[%a]" Fmt.(list ~sep:(any " ") pp_key) keys + + let str_keys = Fmt.to_to_string pp_keys + let lca_calls = ref 0 + + let rec unqueue todo seen = + if Queue.is_empty todo then None + else + let ((_, commit) as pop) = Queue.pop todo in + if KSet.mem commit seen then unqueue todo seen else Some pop + + (* Traverse the graph of commits using a breadth first search + strategy. Start by visiting the commits in [init] and stops + either when [check] returns [`Stop] or when all the ancestors of + [init] have been visited. *) + let traverse_bfs t ~f ~pp:_ ~check ~init ~return = + let todo = Queue.create () in + let add_todo d x = Queue.add (d, x) todo in + KSet.iter (add_todo 0) init; + let rec aux seen = + match check () with + | (`Too_many_lcas | `Max_depth_reached) as x -> Lwt.return (Error x) + | `Stop -> return () + | `Continue -> ( + match unqueue todo seen with + | None -> return () + | Some (depth, commit) -> + (* Log.debug "lca %d: %s.%d %a" + !lca_calls (pp_key commit) depth force (pp ()); *) + let seen = KSet.add commit seen in + let* parents = read_parents t commit in + let () = f depth commit parents in + let parents = KSet.diff parents seen in + KSet.iter (add_todo (depth + 1)) parents; + aux seen) + in + aux KSet.empty + + (* Initially the first node is marked as [Seen1] and the second as [Seen2]. + Marks are updated as the search progresses, and may change. *) + type mark = + | Seen1 (* reachable from the first commit *) + | Seen2 (* reachable from the second commit *) + | SeenBoth (* reachable from both, but below an LCA *) + | LCA + + (* reachable from both; candidate for the answer set *) + + let _pp_mark = function + | Seen1 -> "seen1" + | Seen2 -> "seen2" + | SeenBoth -> "seenBoth" + | LCA -> "LCA" + + (* Exploration state *) + type state = { + marks : mark KHashtbl.t; + (* marks of commits already explored *) + parents : KSet.t KHashtbl.t; + (* parents of commits already explored *) + layers : (int, KSet.t) Hashtbl.t; + (* layers of commit, sorted by depth *) + c1 : S.key; + (* initial state 1 *) + c2 : S.key; + (* initial state 2 *) + mutable depth : int; + (* the current exploration depth *) + mutable lcas : int; + (* number of commit marked with LCA *) + mutable complete : bool; (* is the exploration complete? *) + } + + let pp_state t = + lazy + (let pp m = + KHashtbl.fold + (fun k v acc -> if v = m then str_key k :: acc else acc) + t.marks [] + |> String.concat " " + in + Fmt.str "d: %d, seen1: %s, seen2: %s, seenboth: %s, lcas: %s (%d) %s" + t.depth (pp Seen1) (pp Seen2) (pp SeenBoth) (pp LCA) t.lcas + (String.concat " | " + (Hashtbl.fold + (fun d ks acc -> Fmt.str "(%d: %s)" d (str_keys ks) :: acc) + t.layers []))) + + let get_mark_exn t elt = KHashtbl.find t.marks elt + let get_mark t elt = try Some (get_mark_exn t elt) with Not_found -> None + let set_mark t elt mark = KHashtbl.replace t.marks elt mark + let get_layer t d = try Hashtbl.find t.layers d with Not_found -> KSet.empty + + let add_to_layer t d k = + Hashtbl.replace t.layers d (KSet.add k (get_layer t d)) + + let add_parent t c p = KHashtbl.add t.parents c p + + let get_parent t c = + try KHashtbl.find t.parents c with Not_found -> KSet.empty + + let incr_lcas t = t.lcas <- t.lcas + 1 + let decr_lcas t = t.lcas <- t.lcas - 1 + + let both_seen t k = + match get_mark t k with + | None | Some Seen1 | Some Seen2 -> false + | _ -> true + + let empty_state c1 c2 = + let t = + { + marks = KHashtbl.create 10; + parents = KHashtbl.create 10; + layers = Hashtbl.create 10; + c1; + c2; + depth = 0; + lcas = 0; + complete = false; + } + in + set_mark t c1 Seen1; + set_mark t c2 Seen2; + t + + (* update the parent mark and keep the number of lcas up-to-date. *) + let update_mark t mark commit = + let new_mark = + match (mark, get_mark t commit) with + | Seen1, Some Seen1 | Seen1, None -> Seen1 + | Seen2, Some Seen2 | Seen2, None -> Seen2 + | SeenBoth, Some LCA -> + decr_lcas t; + SeenBoth + | SeenBoth, _ -> SeenBoth + | Seen1, Some Seen2 | Seen2, Some Seen1 -> + incr_lcas t; + LCA + | _, Some LCA -> LCA + | _ -> SeenBoth + in + (* check for fast-forwards *) + let is_init () = equal_keys commit t.c1 || equal_keys commit t.c2 in + let is_shared () = new_mark = SeenBoth || new_mark = LCA in + if is_shared () && is_init () then ( + [%log.debug "fast-forward"]; + t.complete <- true); + set_mark t commit new_mark; + new_mark + + (* update the ancestors which have already been visisted. *) + let update_ancestors_marks t mark commit = + let todo = Queue.create () in + Queue.add commit todo; + let rec loop mark = + if Queue.is_empty todo then () + else + let a = Queue.pop todo in + let old_mark = get_mark t a in + let mark = update_mark t mark a in + let () = + match old_mark with + | Some (SeenBoth | LCA) -> () (* Can't be an LCA lower down *) + | Some old when old = mark -> () (* No change *) + | _ -> KSet.iter (fun x -> Queue.push x todo) (get_parent t a) + in + loop (if mark = LCA then SeenBoth else mark) + in + loop mark + + (* We are looking for LCAs, doing a breadth-first-search from the two starting commits. + This is called each time we visit a new commit. *) + let update_parents t depth commit parents = + add_parent t commit parents; + add_to_layer t depth commit; + if depth <> t.depth then ( + assert (depth = t.depth + 1); + + (* before starting to explore a new layer, check if we really + have some work to do, ie. do we still have a commit seen only + by one node? *) + let layer = get_layer t t.depth in + let complete = KSet.for_all (both_seen t) layer in + if complete then t.complete <- true else t.depth <- depth); + let mark = get_mark_exn t commit in + KSet.iter (update_ancestors_marks t mark) parents + + let lcas t = + KHashtbl.fold (fun k v acc -> if v = LCA then k :: acc else acc) t.marks [] + + let check ~max_depth ~n t = + if t.depth > max_depth then `Max_depth_reached + else if t.lcas > n then `Too_many_lcas + else if t.lcas = n || t.complete then `Stop + else `Continue + + let lcas t ?(max_depth = max_int) ?(n = max_int) c1 c2 = + incr lca_calls; + if max_depth < 0 then Lwt.return (Error `Max_depth_reached) + else if n <= 0 then Lwt.return (Error `Too_many_lcas) + else if equal_keys c1 c2 then Lwt.return (Ok [ c1 ]) + else + let init = KSet.of_list [ c1; c2 ] in + let s = empty_state c1 c2 in + let check () = check ~max_depth ~n s in + let pp () = pp_state s in + let return () = Lwt.return (Ok (lcas s)) in + let t0 = Sys.time () in + Lwt.finalize + (fun () -> + traverse_bfs t ~f:(update_parents s) ~pp ~check ~init ~return) + (fun () -> + let t1 = Sys.time () -. t0 in + [%log.debug "lcas %d: depth=%d time=%.4fs" !lca_calls s.depth t1]; + Lwt.return_unit) + + let rec three_way_merge t ~info ?max_depth ?n c1 c2 = + [%log.debug "3-way merge between %a and %a" pp_key c1 pp_key c2]; + if equal_keys c1 c2 then Merge.ok c1 + else + let* lcas = lcas t ?max_depth ?n c1 c2 in + let old () = + match lcas with + | Error `Too_many_lcas -> Merge.conflict "Too many lcas" + | Error `Max_depth_reached -> Merge.conflict "Max depth reached" + | Ok [] -> Merge.ok None (* no common ancestor *) + | Ok (old :: olds) -> + let rec aux acc = function + | [] -> Merge.ok (Some acc) + | old :: olds -> + three_way_merge t ~info acc old >>=* fun acc -> aux acc olds + in + aux old olds + in + let merge = + merge t ~info + |> Merge.with_conflict (fun msg -> + Fmt.str "Recursive merging of common ancestors: %s" msg) + |> Merge.f + in + merge ~old c1 c2 + + let lca_aux t ~info ?max_depth ?n c1 c2 = + if equal_keys c1 c2 then Merge.ok (Some c1) + else + lcas t ?max_depth ?n c1 c2 >>= function + | Error `Too_many_lcas -> Merge.conflict "Too many lcas" + | Error `Max_depth_reached -> Merge.conflict "Max depth reached" + | Ok [] -> Merge.ok None (* no common ancestor *) + | Ok [ x ] -> Merge.ok (Some x) + | Ok (c :: cs) -> + let rec aux acc = function + | [] -> Merge.ok (Some acc) + | c :: cs -> ( + three_way_merge t ~info ?max_depth ?n acc c >>= function + | Error (`Conflict _) -> Merge.ok None + | Ok acc -> aux acc cs) + in + aux c cs + + let rec lca t ~info ?max_depth ?n = function + | [] -> Merge.conflict "History.lca: empty" + | [ c ] -> Merge.ok (Some c) + | c1 :: c2 :: cs -> ( + lca_aux t ~info ?max_depth ?n c1 c2 >>=* function + | None -> Merge.ok None + | Some c -> lca t ~info ?max_depth ?n (c :: cs)) +end + +module V1 = struct + module Info = struct + include Info.Default + + let t : t Type.t = + let open Type in + record "info" (fun date author message -> v ~author ~message date) + |+ field "date" int64 (fun t -> date t) + |+ field "author" (string_of `Int64) (fun t -> author t) + |+ field "message" (string_of `Int64) (fun t -> message t) + |> sealr + end + + module Make (Hash : Hash.S) (C : Generic_key.S with module Info := Info) = + struct + module K (K : Type.S) = struct + let h = Type.string_of `Int64 + + type t = K.t [@@deriving irmin ~pre_hash ~to_bin_string ~of_bin_string] + + let size_of = Type.Size.using to_bin_string (Type.Size.t h) + + let encode_bin = + let encode_bin = Type.(unstage (encode_bin h)) in + fun e k -> encode_bin (to_bin_string e) k + + let decode_bin = + let decode_bin = Type.(unstage (decode_bin h)) in + fun buf pos_ref -> + let v = decode_bin buf pos_ref in + match of_bin_string v with + | Ok v -> v + | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e + + (* Manually box hashes in V1 commits with length headers: *) + let pre_hash = + let hash_length_header : string = + let b = Bytes.create 8 in + Bytes.set_int64_be b 0 (Int64.of_int Hash.hash_size); + Bytes.unsafe_to_string b + in + fun x f -> + f hash_length_header; + pre_hash x f + + let t = Type.like K.t ~bin:(encode_bin, decode_bin, size_of) ~pre_hash + end + + module Node_key = K (struct + type t = C.node_key [@@deriving irmin] + end) + + module Commit_key = K (struct + type t = C.commit_key [@@deriving irmin] + end) + + type node_key = Node_key.t [@@deriving irmin] + type commit_key = Commit_key.t [@@deriving irmin] + type t = { parents : commit_key list; c : C.t } + + module Info = Info + + let import c = { c; parents = C.parents c } + let export t = t.c + let node t = C.node t.c + let parents t = t.parents + let info t = C.info t.c + let v ~info ~node ~parents = { parents; c = C.v ~node ~parents ~info } + let make = v + + let t : t Type.t = + let open Type in + record "commit" (fun node parents info -> make ~info ~node ~parents) + |+ field "node" Node_key.t node + |+ field "parents" (list ~len:`Int64 Commit_key.t) parents + |+ field "info" Info.t info + |> sealr + end +end + +include Maker (Info.Default) diff --git a/vendors/irmin/src/irmin/commit.mli b/vendors/irmin/src/irmin/commit.mli new file mode 100644 index 0000000000000000000000000000000000000000..0bd9361dc315bb16a7eb9aea43c72685e48c3752 --- /dev/null +++ b/vendors/irmin/src/irmin/commit.mli @@ -0,0 +1,27 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Commit values represent the store history. + + Every commit contains a list of predecessor commits, and the collection of + commits form an acyclic directed graph. + + Every commit also can contain an optional key, pointing to a + {{!Backend.Commit.Store} node} value. See the {{!Backend.Node.Store} Node} + signature for more details on node values. *) + +include Commit_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/commit_intf.ml b/vendors/irmin/src/irmin/commit_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..51de11896625525bb95c491ff05da24e594e9953 --- /dev/null +++ b/vendors/irmin/src/irmin/commit_intf.ml @@ -0,0 +1,330 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S_generic_key = sig + (** {1 Commit values} *) + + type t [@@deriving irmin] + (** The type for commit values. *) + + type node_key [@@deriving irmin] + (** Type for node keys. *) + + type commit_key [@@deriving irmin] + (** Type for commit keys. *) + + module Info : Info.S + (** The type for commit info. *) + + val v : info:Info.t -> node:node_key -> parents:commit_key list -> t + (** Create a commit. *) + + val node : t -> node_key + (** The underlying node key. *) + + val parents : t -> commit_key list + (** The commit parents. *) + + val info : t -> Info.t + (** The commit info. *) +end + +module type S = sig + type hash [@@deriving irmin] + + (** @inline *) + include S_generic_key with type node_key = hash and type commit_key = hash +end + +module type Portable = sig + include S + + type commit + + val of_commit : commit -> t +end + +open struct + module S_is_a_generic_key (X : S) : S_generic_key = X +end + +module type Maker_generic_key = sig + module Info : Info.S + + module Make + (H : Type.S) + (N : Key.S with type hash = H.t) + (C : Key.S with type hash = H.t) : sig + include + S_generic_key + with type node_key = N.t + and type commit_key = C.t + and module Info = Info + + module Portable : + Portable with type commit := t and type hash := H.t and module Info = Info + end + + module Make_v2 + (H : Type.S) + (N : Key.S with type hash = H.t) + (C : Key.S with type hash = H.t) : sig + include + S_generic_key + with type node_key = N.t + and type commit_key = C.t + and module Info = Info + + module Portable : + Portable with type commit := t and type hash := H.t and module Info = Info + end +end + +module type Maker = sig + module Info : Info.S + module Make (H : Type.S) : S with type hash = H.t and module Info = Info +end + +module type Store = sig + (** {1 Commit Store} *) + + include Indexable.S + + module Info : Info.S + (** Commit info. *) + + (** [Val] provides functions for commit values. *) + module Val : + S_generic_key + with type t = value + and type commit_key = key + and module Info := Info + + module Hash : Hash.Typed with type t = hash and type value = value + + module Node : Node.Store with type key = Val.node_key + (** [Node] is the underlying node store. *) + + val merge : [> read_write ] t -> info:Info.f -> key option Merge.t + (** [merge] is the 3-way merge function for commit keys. *) +end + +module type History = sig + (** {1 Commit History} *) + + type 'a t + (** The type for store handles. *) + + type node_key [@@deriving irmin] + (** The type for node keys. *) + + type commit_key [@@deriving irmin] + (** The type for commit keys. *) + + type v [@@deriving irmin] + (** The type for commit objects. *) + + type info [@@deriving irmin] + (** The type for commit info. *) + + val v : + [> write ] t -> + node:node_key -> + parents:commit_key list -> + info:info -> + (commit_key * v) Lwt.t + (** Create a new commit. *) + + val parents : [> read ] t -> commit_key -> commit_key list Lwt.t + (** Get the commit parents. + + Commits form a append-only, fully functional, partial-order + data-structure: every commit carries the list of its immediate + predecessors. *) + + val merge : [> read_write ] t -> info:(unit -> info) -> commit_key Merge.t + (** [merge t] is the 3-way merge function for commit. *) + + val lcas : + [> read ] t -> + ?max_depth:int -> + ?n:int -> + commit_key -> + commit_key -> + (commit_key list, [ `Max_depth_reached | `Too_many_lcas ]) result Lwt.t + (** Find the lowest common ancestors + {{:http://en.wikipedia.org/wiki/Lowest_common_ancestor} lca} between two + commits. *) + + val lca : + [> read_write ] t -> + info:(unit -> info) -> + ?max_depth:int -> + ?n:int -> + commit_key list -> + (commit_key option, Merge.conflict) result Lwt.t + (** Compute the lowest common ancestors ancestor of a list of commits by + recursively calling {!lcas} and merging the results. + + If one of the merges results in a conflict, or if a call to {!lcas} + returns either [Error `Max_depth_reached] or [Error `Too_many_lcas] then + the function returns the same error. *) + + val three_way_merge : + [> read_write ] t -> + info:(unit -> info) -> + ?max_depth:int -> + ?n:int -> + commit_key -> + commit_key -> + (commit_key, Merge.conflict) result Lwt.t + (** Compute the {!lcas} of the two commit and 3-way merge the result. *) + + val closure : + [> read ] t -> + min:commit_key list -> + max:commit_key list -> + commit_key list Lwt.t + (** Same as {{!Node.Graph.closure} Node.Graph.closure} but for the history + graph. *) + + val iter : + [> read ] t -> + min:commit_key list -> + max:commit_key list -> + ?commit:(commit_key -> unit Lwt.t) -> + ?edge:(commit_key -> commit_key -> unit Lwt.t) -> + ?skip:(commit_key -> bool Lwt.t) -> + ?rev:bool -> + unit -> + unit Lwt.t + (** Same as {{!Node.Graph.iter} Node.Graph.iter} but for traversing the + history graph. *) +end + +module type Sigs = sig + module type S = S + module type Maker = Maker + + (** [Maker] provides a simple implementation of commit values, parameterized + by commit info. *) + module Maker (I : Info.S) : Maker with module Info = I + + (** [Generic_key] generalises the concept of "commit" to one that supports + object keys that are not strictly equal to hashes. *) + module Generic_key : sig + module type S = S_generic_key + module type Maker = Maker_generic_key + + module Maker (I : Info.S) : Maker with module Info = I + + module Store + (I : Info.S) + (N : Node.Store) + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (V : S + with type node_key = N.key + and type commit_key = S.key + and type t = S.value + and module Info := I) : + Store + with type 'a t = 'a N.t * 'a S.t + and type key = S.key + and type value = S.value + and module Info = I + and type hash = S.hash + and module Val = V + + include Maker with module Info = Info.Default + end + + (** V1 serialisation. *) + module V1 : sig + module Info : Info.S with type t = Info.Default.t + (** Serialisation format for V1 info. *) + + module Make (Hash : Hash.S) (C : Generic_key.S with module Info := Info) : sig + include + Generic_key.S + with module Info = Info + and type node_key = C.node_key + and type commit_key = C.commit_key + + val import : C.t -> t + val export : t -> C.t + end + end + + module Portable : sig + (** Portable form of a commit implementation that can be constructed from a + concrete representation and used in computing hashes. Conceptually, a + [Commit.Portable.t] is a [Commit.t] in which all internal keys have been + replaced with the hashes of the values they point to. + + As with {!Node.Portable}, computations over portable values must commute + with those over [t]s. *) + + (** A node implementation with hashes for keys is trivially portable: *) + module Of_commit (S : S) : + Portable + with type commit := S.t + and type t = S.t + and type hash = S.hash + and module Info = S.Info + + module type S = Portable + end + + module type Store = Store + (** [Store] specifies the signature for commit stores. *) + + (** [Store] creates a new commit store. *) + module Store + (I : Info.S) + (N : Node.Store) + (S : Content_addressable.S with type key = N.key) + (H : Hash.S with type t = S.key) + (V : S with type hash = S.key and type t = S.value and module Info := I) : + Store + with type 'a t = 'a N.t * 'a S.t + and type key = S.key + and type hash = S.key + and type value = S.value + and module Info = I + and module Val = V + + module type History = History + (** [History] specifies the signature for commit history. The history is + represented as a partial-order of commits and basic functions to search + through that history are provided. + + Every commit can point to an entry point in a node graph, where + user-defined contents are stored. *) + + (** Build a commit history. *) + module History (C : Store) : + History + with type 'a t = 'a C.t + and type v = C.Val.t + and type node_key = C.Node.key + and type commit_key = C.key + and type info = C.Info.t + + include Maker with module Info = Info.Default +end diff --git a/vendors/irmin/src/irmin/conf.ml b/vendors/irmin/src/irmin/conf.ml new file mode 100644 index 0000000000000000000000000000000000000000..66116465ddba5a1da3a1c28d6f8ca2b440d1ef43 --- /dev/null +++ b/vendors/irmin/src/irmin/conf.ml @@ -0,0 +1,156 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2017 Daniel C. Bünzli + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Univ = struct + type t = exn + + let create (type s) () = + let module M = struct + exception E of s option + end in + ((fun x -> M.E (Some x)), function M.E x -> x | _ -> None) +end + +type 'a key = { + name : string; + doc : string option; + docv : string option; + docs : string option; + ty : 'a Type.t; + default : 'a; + to_univ : 'a -> Univ.t; + of_univ : Univ.t -> 'a option; +} + +type k = K : 'a key -> k + +module M = Map.Make (struct + type t = k + + let compare (K a) (K b) = String.compare a.name b.name +end) + +module Spec = struct + module M = Map.Make (String) + + type t = { name : string; mutable keys : k M.t } + + let all = Hashtbl.create 8 + + let v name = + let keys = M.empty in + if Hashtbl.mem all name then + Fmt.failwith "Config spec already exists: %s" name; + let x = { name; keys } in + Hashtbl.replace all name x; + x + + let name { name; _ } = name + let update spec name k = spec.keys <- M.add name k spec.keys + let list () = Hashtbl.to_seq_values all + let find name = Hashtbl.find_opt all name + let find_key spec name = M.find_opt name spec.keys + let keys spec = M.to_seq spec.keys |> Seq.map snd + let clone { name; keys } = { name; keys } + + let join dest src = + let dest = clone dest in + let name = ref dest.name in + let keys = + List.fold_left + (fun acc spec -> + if dest.name = spec.name then acc + else + let () = name := !name ^ "-" ^ spec.name in + M.add_seq (M.to_seq spec.keys) acc) + dest.keys src + in + { name = !name; keys } +end + +type t = Spec.t * Univ.t M.t + +let spec = fst + +let key ?docs ?docv ?doc ~spec name ty default = + let () = + String.iter + (function + | '-' | '_' | 'a' .. 'z' | '0' .. '9' -> () + | _ -> raise @@ Invalid_argument name) + name + in + let to_univ, of_univ = Univ.create () in + let k = { name; ty; default; to_univ; of_univ; doc; docv; docs } in + Spec.update spec name (K k); + k + +let name t = t.name +let doc t = t.doc +let docv t = t.docv +let docs t = t.docs +let ty t = t.ty +let default t = t.default +let empty spec = (spec, M.empty) +let singleton spec k v = (spec, M.singleton (K k) (k.to_univ v)) +let is_empty (_, t) = M.is_empty t +let mem (_, d) k = M.mem (K k) d + +let add (spec, d) k v = + if Spec.find_key spec k.name |> Option.is_none then + Fmt.invalid_arg "invalid config key: %s" k.name + else (spec, M.add (K k) (k.to_univ v) d) + +let verify (spec, d) = + M.iter + (fun (K k) _ -> + if Spec.find_key spec k.name |> Option.is_none then + Fmt.invalid_arg "invalid config key: %s" k.name) + d; + (spec, d) + +let union (rs, r) (ss, s) = + let spec = Spec.join rs [ ss ] in + (spec, M.fold M.add r s) + +let rem (s, d) k = (s, M.remove (K k) d) +let find (_, d) k = try k.of_univ (M.find (K k) d) with Not_found -> None +let uri = Type.(map string) Uri.of_string Uri.to_string + +let get (_, d) k = + try + match k.of_univ (M.find (K k) d) with + | Some v -> v + | None -> raise Not_found + with Not_found -> k.default + +let keys (_, conf) = M.to_seq conf |> Seq.map (fun (k, _) -> k) +let with_spec (_, conf) spec = (spec, conf) + +(* ~root *) +let root spec = + key ~spec ~docv:"ROOT" ~doc:"The location of the Irmin store on disk." + ~docs:"COMMON OPTIONS" "root" + Type.(string) + "." + +let find_root (spec, d) : string option = + match Spec.find_key spec "root" with + | None -> None + | Some (K k) -> ( + let v = find (spec, d) k in + match v with None -> None | Some v -> Some (Type.to_string k.ty v)) diff --git a/vendors/irmin/src/irmin/conf.mli b/vendors/irmin/src/irmin/conf.mli new file mode 100644 index 0000000000000000000000000000000000000000..78095bcb2ae2e973c4510f4870baba615a8f20ea --- /dev/null +++ b/vendors/irmin/src/irmin/conf.mli @@ -0,0 +1,160 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** {1 Configuration converters} + + A configuration converter transforms a string value to an OCaml value and + vice-versa. *) + +(** {1:keys Keys} *) + +type 'a key +(** The type for configuration keys whose lookup value is ['a]. *) + +type k = K : 'a key -> k + +module Spec : sig + type t + (** A configuration spec is used to group keys by backend *) + + val v : string -> t + (** [v name] is a new configuration specification named [name] *) + + val name : t -> string + (** [name spec] is the name associated with a config spec *) + + val list : unit -> t Seq.t + (** [list ()] is a sequence containing all available config specs *) + + val find : string -> t option + (** [find name] is the config spec associated with [name] if available *) + + val find_key : t -> string -> k option + (** [find_key spec k] is the key associated with the name [k] in [spec] *) + + val keys : t -> k Seq.t + (** [keys spec] is a sequence of keys available in [spec] *) + + val join : t -> t list -> t + (** [join a b] is a new [Spec.t] combining [a] and all specs present in [b] + + The name of the resulting spec will be the name of [a] and the names of + the specs in [b] joined by hyphens. *) +end + +val key : + ?docs:string -> + ?docv:string -> + ?doc:string -> + spec:Spec.t -> + string -> + 'a Type.t -> + 'a -> + 'a key +(** [key ~docs ~docv ~doc ~spec name conv default] is a configuration key named + [name] that maps to value [default] by default. It will be associated with + the config grouping [spec]. [conv] is used to convert key values provided by + end users. + + [docs] is the title of a documentation section under which the key is + documented. [doc] is a short documentation string for the key, this should + be a single sentence or paragraph starting with a capital letter and ending + with a dot. [docv] is a meta-variable for representing the values of the key + (e.g. ["BOOL"] for a boolean). + + @raise Invalid_argument + if the key name is not made of a sequence of ASCII lowercase letter, + digit, dash or underscore. + + {b Warning.} No two keys should share the same [name] as this may lead to + difficulties in the UI. *) + +val name : 'a key -> string +(** The key name. *) + +val ty : 'a key -> 'a Type.t +(** [tc k] is [k]'s converter. *) + +val default : 'a key -> 'a +(** [default k] is [k]'s default value. *) + +val doc : 'a key -> string option +(** [doc k] is [k]'s documentation string (if any). *) + +val docv : 'a key -> string option +(** [docv k] is [k]'s value documentation meta-variable (if any). *) + +val docs : 'a key -> string option +(** [docs k] is [k]'s documentation section (if any). *) + +val root : Spec.t -> string key +(** Default [--root=ROOT] argument. *) + +(** {1:conf Configurations} *) + +type t +(** The type for configurations. *) + +val spec : t -> Spec.t +(** [spec c] is the specification associated with [c] *) + +val empty : Spec.t -> t +(** [empty spec] is an empty configuration. *) + +val singleton : Spec.t -> 'a key -> 'a -> t +(** [singleton spec k v] is the configuration where [k] maps to [v]. *) + +val is_empty : t -> bool +(** [is_empty c] is [true] iff [c] is empty. *) + +val mem : t -> 'a key -> bool +(** [mem c k] is [true] iff [k] has a mapping in [c]. *) + +val add : t -> 'a key -> 'a -> t +(** [add c k v] is [c] with [k] mapping to [v]. *) + +val rem : t -> 'a key -> t +(** [rem c k] is [c] with [k] unbound. *) + +val union : t -> t -> t +(** [union r s] is the union of the configurations [r] and [s]. *) + +val find : t -> 'a key -> 'a option +(** [find c k] is [k]'s mapping in [c], if any. *) + +val get : t -> 'a key -> 'a +(** [get c k] is [k]'s mapping in [c]. + + {b Raises.} [Not_found] if [k] is not bound in [d]. *) + +val keys : t -> k Seq.t +(** [keys c] is a sequence of all keys present in [c] *) + +val with_spec : t -> Spec.t -> t +(** [with_spec t s] is the config [t] with spec [s] *) + +val verify : t -> t +(** [verify t] is an identity function that ensures all keys match the spec + + {b Raises.} [Invalid_argument] if [t] contains invalid keys *) + +(** {1:builtin_converters Built-in value converters} *) + +val uri : Uri.t Type.t +(** [uri] converts values with {!Uri.of_string}. *) + +val find_root : t -> string option +(** [find_root c] is [root]'s mapping in [c], if any. *) diff --git a/vendors/irmin/src/irmin/content_addressable.ml b/vendors/irmin/src/irmin/content_addressable.ml new file mode 100644 index 0000000000000000000000000000000000000000..aa7b506b5cb0b70ba64f0c0dc175672cf2803d14 --- /dev/null +++ b/vendors/irmin/src/irmin/content_addressable.ml @@ -0,0 +1,84 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Content_addressable_intf + +module Make (AO : Append_only.Maker) (K : Hash.S) (V : Type.S) = struct + include AO (K) (V) + open Lwt.Infix + module H = Hash.Typed (K) (V) + + let hash = H.hash + let pp_key = Type.pp K.t + let equal_hash = Type.(unstage (equal K.t)) + + let find t k = + find t k >>= function + | None -> Lwt.return_none + | Some v as r -> + let k' = hash v in + if equal_hash k k' then Lwt.return r + else + Fmt.kstr Lwt.fail_invalid_arg "corrupted value: got %a, expecting %a" + pp_key k' pp_key k + + let unsafe_add t k v = add t k v + + let add t v = + let k = hash v in + add t k v >|= fun () -> k +end + +module Check_closed (CA : Maker) (K : Hash.S) (V : Type.S) = struct + module S = CA (K) (V) + + type 'a t = { closed : bool ref; t : 'a S.t } + type key = S.key + type value = S.value + + let check_not_closed t = if !(t.closed) then raise Store_properties.Closed + + let mem t k = + check_not_closed t; + S.mem t.t k + + let find t k = + check_not_closed t; + S.find t.t k + + let add t v = + check_not_closed t; + S.add t.t v + + let unsafe_add t k v = + check_not_closed t; + S.unsafe_add t.t k v + + let batch t f = + check_not_closed t; + S.batch t.t (fun w -> f { t = w; closed = t.closed }) + + let v conf = + let+ t = S.v conf in + { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) +end diff --git a/vendors/irmin/src/irmin/content_addressable.mli b/vendors/irmin/src/irmin/content_addressable.mli new file mode 100644 index 0000000000000000000000000000000000000000..ed9b4cc43d037ad0981dba9e2c9b72bb6eda09a0 --- /dev/null +++ b/vendors/irmin/src/irmin/content_addressable.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Content_addressable_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/content_addressable_intf.ml b/vendors/irmin/src/irmin/content_addressable_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..1c0fe4a1e497a424dec91f37a9b6947e142b1342 --- /dev/null +++ b/vendors/irmin/src/irmin/content_addressable_intf.ml @@ -0,0 +1,69 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +open Store_properties + +module type S = sig + (** A {i content-addressable} store is an indexed read-write store in which + values are keyed directly by their hashes. *) + + include Read_only.S + (** @inline *) + + val add : [> write ] t -> value -> key Lwt.t + (** Write the contents of a value to the store. It's the responsibility of the + content-addressable store to generate a consistent key. *) + + val unsafe_add : [> write ] t -> key -> value -> unit Lwt.t + (** Same as {!add} but allows specifying the key directly. The backend might + choose to discard that key and/or can be corrupt if the key scheme is not + consistent. *) + + include Closeable with type 'a t := 'a t + (** @inline *) + + include Batch with type 'a t := 'a t + (** @inline *) +end + +module type Maker = functor (Hash : Hash.S) (Value : Type.S) -> sig + include S with type value = Value.t and type key = Hash.t + + include Of_config with type 'a t := 'a t + (** @inline *) +end + +module type Sigs = sig + module type S = S + module type Maker = Maker + + module Make + (Append_only_maker : Append_only.Maker) + (Hash : Hash.S) + (Value : Type.S) : sig + include + S + with type 'a t = 'a Append_only_maker(Hash)(Value).t + and type value = Value.t + and type key = Hash.t + + include Of_config with type 'a t := 'a t + (** @inline *) + end + + module Check_closed (M : Maker) : Maker +end diff --git a/vendors/irmin/src/irmin/contents.ml b/vendors/irmin/src/irmin/contents.ml new file mode 100644 index 0000000000000000000000000000000000000000..9cc3126f996e36755187fac751e4343ff82a87bd --- /dev/null +++ b/vendors/irmin/src/irmin/contents.ml @@ -0,0 +1,251 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Contents_intf + +let lexeme e x = ignore (Jsonm.encode e (`Lexeme x)) + +let rec encode_json e = function + | `Null -> lexeme e `Null + | `Bool b -> lexeme e (`Bool b) + | `String s -> lexeme e (`String s) + | `Float f -> lexeme e (`Float f) + | `A a -> + lexeme e `As; + List.iter (encode_json e) a; + lexeme e `Ae + | `O o -> + lexeme e `Os; + List.iter + (fun (k, v) -> + lexeme e (`Name k); + encode_json e v) + o; + lexeme e `Oe + +let decode_json d = + let decode d = + match Jsonm.decode d with + | `Lexeme l -> l + | `Error e -> failwith (Fmt.str "%a" Jsonm.pp_error e) + | _ -> failwith "invalid JSON encoding" + in + let rec unwrap v d = + match v with + | `Os -> obj [] d + | `As -> arr [] d + | (`Null | `Bool _ | `String _ | `Float _) as v -> v + | _ -> failwith "invalid JSON value" + and arr vs d = + match decode d with + | `Ae -> `A (List.rev vs) + | v -> + let v = unwrap v d in + arr (v :: vs) d + and obj ms d = + match decode d with + | `Oe -> `O (List.rev ms) + | `Name k -> + let v = unwrap (decode d) d in + obj ((k, v) :: ms) d + | _ -> failwith "invalid JSON object" + in + try Ok (unwrap (decode d) d) with Failure msg -> Error (`Msg msg) + +type json = + [ `Null + | `Bool of bool + | `String of string + | `Float of float + | `O of (string * json) list + | `A of json list ] +[@@deriving irmin] + +module Json_value = struct + type t = json [@@deriving irmin] + + let pp fmt x = + let buffer = Buffer.create 32 in + let encoder = Jsonm.encoder (`Buffer buffer) in + encode_json encoder x; + ignore @@ Jsonm.encode encoder `End; + let s = Buffer.contents buffer in + Fmt.pf fmt "%s" s + + let of_string s = + let decoder = Jsonm.decoder (`String s) in + match decode_json decoder with Ok obj -> Ok obj | Error _ as err -> err + + let equal_bool = Type.(unstage (equal bool)) + let equal_float = Type.(unstage (equal float)) + + let rec equal a b = + match (a, b) with + | `Null, `Null -> true + | `Bool a, `Bool b -> equal_bool a b + | `String a, `String b -> String.equal a b + | `Float a, `Float b -> equal_float a b + | `A a, `A b -> ( + try List.for_all2 (fun a' b' -> equal a' b') a b + with Invalid_argument _ -> false) + | `O a, `O b -> ( + let compare_fst (a, _) (b, _) = compare a b in + try + List.for_all2 + (fun (k, v) (k', v') -> k = k' && equal v v') + (List.sort compare_fst a) (List.sort compare_fst b) + with Invalid_argument _ -> false) + | _, _ -> false + + let t = Type.like ~equal ~pp ~of_string t + + let rec merge_object ~old x y = + let open Merge.Infix in + let m = + Merge.(alist Type.string t (fun _key -> option (v t merge_value))) + in + Merge.(f m ~old x y) >>=* fun x -> Merge.ok (`O x) + + and merge_float ~old x y = + let open Merge.Infix in + Merge.(f float ~old x y) >>=* fun f -> Merge.ok (`Float f) + + and merge_string ~old x y = + let open Merge.Infix in + Merge.(f string ~old x y) >>=* fun s -> Merge.ok (`String s) + + and merge_bool ~old x y = + let open Merge.Infix in + Merge.(f bool ~old x y) >>=* fun b -> Merge.ok (`Bool b) + + and merge_array ~old x y = + let open Merge.Infix in + Merge.(f (Merge.idempotent (Type.list t)) ~old x y) >>=* fun x -> + Merge.ok (`A x) + + and merge_value ~old x y = + let open Merge.Infix in + old () >>=* fun old -> + match (old, x, y) with + | Some `Null, _, _ -> merge_value ~old:(fun () -> Merge.ok None) x y + | None, `Null, `Null -> Merge.ok `Null + | Some (`Float old), `Float a, `Float b -> + merge_float ~old:(fun () -> Merge.ok (Some old)) a b + | None, `Float a, `Float b -> merge_float ~old:(fun () -> Merge.ok None) a b + | Some (`String old), `String a, `String b -> + merge_string ~old:(fun () -> Merge.ok (Some old)) a b + | None, `String a, `String b -> + merge_string ~old:(fun () -> Merge.ok None) a b + | Some (`Bool old), `Bool a, `Bool b -> + merge_bool ~old:(fun () -> Merge.ok (Some old)) a b + | None, `Bool a, `Bool b -> merge_bool ~old:(fun () -> Merge.ok None) a b + | Some (`A old), `A a, `A b -> + merge_array ~old:(fun () -> Merge.ok (Some old)) a b + | None, `A a, `A b -> merge_array ~old:(fun () -> Merge.ok None) a b + | Some (`O old), `O a, `O b -> + merge_object ~old:(fun () -> Merge.ok (Some old)) a b + | None, `O a, `O b -> merge_object ~old:(fun () -> Merge.ok None) a b + | _, _, _ -> Merge.conflict "Conflicting JSON datatypes" + + let merge_json = Merge.(v t merge_value) + let merge = Merge.(option merge_json) +end + +module Json = struct + type t = (string * json) list [@@deriving irmin] + + let pp fmt x = + let buffer = Buffer.create 32 in + let encoder = Jsonm.encoder (`Buffer buffer) in + encode_json encoder (`O x); + ignore @@ Jsonm.encode encoder `End; + let s = Buffer.contents buffer in + Fmt.pf fmt "%s" s + + let of_string s = + let decoder = Jsonm.decoder (`String s) in + match decode_json decoder with + | Ok (`O obj) -> Ok obj + | Ok _ -> Error (`Msg "Irmin JSON values must be objects") + | Error _ as err -> err + + let equal a b = Json_value.equal (`O a) (`O b) + let t = Type.like ~equal ~pp ~of_string t + + let merge = + Merge.(option (alist Type.string Json_value.t (fun _ -> Json_value.merge))) +end + +module String_v2 = struct + type t = string [@@deriving irmin] + + let merge = Merge.idempotent Type.(option string) +end + +module String = struct + type t = string [@@deriving irmin] + + let pre_hash = Type.(unstage (pre_hash t)) + + (* Manually add a prefix to default contents, in order to prevent hash + collision between contents and nodes or commits (see + https://github.com/mirage/irmin/issues/1304). *) + let pre_hash_prefixed x f = + f "B"; + pre_hash x f + + let t = Type.(like t ~pre_hash:pre_hash_prefixed) + let merge = Merge.idempotent Type.(option string) +end + +module Store_indexable + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (C : S with type t = S.value) = +struct + module Val = C + module Hash = Hash.Typed (H) (C) + include S + + let read_opt t = function None -> Lwt.return_none | Some k -> find t k + + let add_opt t = function + | None -> Lwt.return_none + | Some v -> add t v >>= Lwt.return_some + + let merge t = + Merge.like_lwt Type.(option Key.t) Val.merge (read_opt t) (add_opt t) +end + +module Store + (S : Content_addressable.S) + (H : Hash.S with type t = S.key) + (C : S with type t = S.value) = + Store_indexable (Indexable.Of_content_addressable (H) (S)) (H) (C) + +module V1 = struct + module String = struct + include String + + let t = Type.(boxed (string_of `Int64)) + + type nonrec t = t [@@deriving irmin ~encode_bin ~decode_bin ~pre_hash] + + let size_of = Type.Size.t t + let t = Type.like t ~bin:(encode_bin, decode_bin, size_of) ~pre_hash + end +end diff --git a/vendors/irmin/src/irmin/contents.mli b/vendors/irmin/src/irmin/contents.mli new file mode 100644 index 0000000000000000000000000000000000000000..2863917273398ddbbc57ccc5473da9ada043c4b4 --- /dev/null +++ b/vendors/irmin/src/irmin/contents.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Values. *) + +include Contents_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/contents_intf.ml b/vendors/irmin/src/irmin/contents_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..64c0811f84763693af1bede747a3c99154c87da5 --- /dev/null +++ b/vendors/irmin/src/irmin/contents_intf.ml @@ -0,0 +1,107 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + (** {1 Signature for store contents} *) + + type t [@@deriving irmin] + (** The type for user-defined contents. *) + + val merge : t option Merge.t + (** Merge function. Evaluates to [`Conflict msg] if the values cannot be + merged properly. The arguments of the merge function can take [None] to + mean that the key does not exists for either the least-common ancestor or + one of the two merging points. The merge function returns [None] when the + key's value should be deleted. *) +end + +module type Store = sig + include Indexable.S + + val merge : [> read_write ] t -> key option Merge.t + (** [merge t] lifts the merge functions defined on contents values to contents + key. The merge function will: {e (i)} read the values associated with the + given keys, {e (ii)} use the merge function defined on values and + {e (iii)} write the resulting values into the store to get the resulting + key. See {!val-S.merge}. + + If any of these operations fail, return [`Conflict]. *) + + module Val : S with type t = value + module Hash : Hash.Typed with type t = hash and type value = value +end + +module type Sigs = sig + module type S = S + + module String : S with type t = string + (** Contents of type [string], with the {{!Irmin.Merge.default} default} 3-way + merge strategy: assume that update operations are idempotent and conflict + iff values are modified concurrently. *) + + module String_v2 : S with type t = string + (** Similar to [String] above, but the hash computation is compatible with + versions older than irmin.3.0 *) + + type json = + [ `Null + | `Bool of bool + | `String of string + | `Float of float + | `O of (string * json) list + | `A of json list ] + + module Json : S with type t = (string * json) list + (** [Json] contents are associations from strings to [json] values stored as + JSON encoded strings. If the same JSON key has been modified concurrently + with different values then the [merge] function conflicts. *) + + module Json_value : S with type t = json + (** [Json_value] allows any kind of json value to be stored, not only objects. *) + + module V1 : sig + module String : S with type t = string + (** Same as {!String} but use v1 serialisation format. *) + end + + module type Store = Store + (** Contents store. *) + + (** [Store] creates a contents store. *) + module Store + (S : Content_addressable.S) + (H : Hash.S with type t = S.key) + (C : S with type t = S.value) : + Store + with type 'a t = 'a S.t + and type key = H.t + and type hash = H.t + and type value = C.t + + (** [Store_indexable] is like {!Store} but uses an indexable store as a + backend (rather than a content-addressable one). *) + module Store_indexable + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (C : S with type t = S.value) : + Store + with type 'a t = 'a S.t + and type key = S.key + and type value = S.value + and type hash = S.hash +end diff --git a/vendors/irmin/src/irmin/data/dune b/vendors/irmin/src/irmin/data/dune new file mode 100644 index 0000000000000000000000000000000000000000..d0ddd5ce62d8faa6e06a52a36baa9bee2c8a9213 --- /dev/null +++ b/vendors/irmin/src/irmin/data/dune @@ -0,0 +1,6 @@ +(library + (name irmin_data) + (public_name irmin.data) + (libraries bigstringaf fmt) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin/data/fixed_size_string_set.ml b/vendors/irmin/src/irmin/data/fixed_size_string_set.ml new file mode 100644 index 0000000000000000000000000000000000000000..4979a36100bc4826205b1b245f4e0934371b4252 --- /dev/null +++ b/vendors/irmin/src/irmin/data/fixed_size_string_set.ml @@ -0,0 +1,237 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type elt = string + +type t = { + elt_length : int; + hash_elt : elt -> int; + hash_elt_substring : Bigstringaf.t -> off:int -> len:int -> int; + empty_slot : elt; + mutable data : Bigstringaf.t; + mutable data_length : int; + mutable slot_count : int; + mutable cardinal : int; +} + +type hashset = t + +module Slot : sig + type t + + val of_elt : hashset -> elt -> t + val of_elt_substring : hashset -> src:Bigstringaf.t -> src_off:int -> t + val contains : hashset -> t -> elt -> bool + + val contains_substring : + hashset -> t -> src:Bigstringaf.t -> src_off:int -> bool + + val is_empty : hashset -> t -> bool + val get : hashset -> t -> elt + val set : hashset -> t -> elt -> unit + val set_substring : hashset -> t -> src:Bigstringaf.t -> src_off:int -> unit + val next : hashset -> t -> t + val iter_all : hashset -> f:(t -> unit) -> unit + val to_offset : t -> int +end = struct + type t = Offset of int [@@ocaml.unboxed] + + let offset_of_hash h hash = + let index = abs hash mod h.slot_count in + Offset (index * h.elt_length) + + let of_elt h elt = offset_of_hash h (h.hash_elt elt) + + let of_elt_substring h ~src ~src_off = + offset_of_hash h (h.hash_elt_substring src ~off:src_off ~len:h.elt_length) + + let contains h (Offset offset) string = + Bigstringaf.memcmp_string h.data offset string 0 h.elt_length = 0 + + let contains_substring h (Offset offset) ~src ~src_off = + Bigstringaf.memcmp h.data offset src src_off h.elt_length = 0 + + let is_empty h t = contains h t h.empty_slot + + let get h (Offset offset) = + Bigstringaf.substring h.data ~off:offset ~len:h.elt_length + + let set h (Offset offset) elt = + Bigstringaf.blit_from_string elt ~src_off:0 h.data ~dst_off:offset + ~len:h.elt_length + + let set_substring h (Offset offset) ~src ~src_off = + Bigstringaf.blit src ~src_off h.data ~dst_off:offset ~len:h.elt_length + + let next h (Offset offset) = Offset ((offset + h.elt_length) mod h.data_length) + + let iter_all hashset ~f = + assert (hashset.data_length <> 0); + f (Offset 0); + let rec aux = function + | Offset 0 -> () + | offset -> + f offset; + aux (next hashset offset) + in + aux (next hashset (Offset 0)) + + let to_offset (Offset n) = n +end + +let empty_all_slots t = + Slot.iter_all t ~f:(fun slot -> Slot.set t slot t.empty_slot) + +module Default = struct + let hash : string -> int = Hashtbl.hash + let hash_substring t ~off ~len = hash (Bigstringaf.substring t ~off ~len) + let null ~elt_length = String.make elt_length '\000' +end + +let create ~elt_length ?(initial_slots = 0) ?hash ?hash_substring ?null () = + if elt_length <= 0 then + Fmt.invalid_arg "%s.create: element length must be strictly positive" + __MODULE__; + let empty_slot = + match null with Some x -> x | None -> Default.null ~elt_length + in + let hash_elt, hash_elt_substring = + match (hash, hash_substring) with + | Some h, Some h' -> (h, h') + | None, None -> (Default.hash, Default.hash_substring) + | Some _, None | None, Some _ -> + Fmt.invalid_arg + "%s.create: must pass either both [hash] and [hash_substring] or \ + neither" + __MODULE__ + in + let slot_count = + let rec aux n = + if n >= initial_slots then n + else if n * 2 > Sys.max_array_length then n + else aux (n * 2) + in + aux 2 + in + let data_length = slot_count * elt_length in + let data = Bigstringaf.create data_length in + let t = + { + data; + data_length; + hash_elt; + hash_elt_substring; + elt_length; + empty_slot; + slot_count; + cardinal = 0; + } + in + empty_all_slots t; + t + +let load_factor t = + let slots_available = Bigstringaf.length t.data / t.elt_length in + Float.of_int t.cardinal /. Float.of_int slots_available + +type ok_or_duplicate = [ `Ok | `Duplicate ] + +let rec unguarded_add t slot elt : ok_or_duplicate = + if Slot.is_empty t slot then ( + (* Write the element to this slot *) + Slot.set t slot elt; + `Ok) + else if Slot.contains t slot elt then `Duplicate + else unguarded_add t (Slot.next t slot) elt + +let rec unguarded_add_substring t slot ~src ~src_off : ok_or_duplicate = + if Slot.is_empty t slot then ( + (* Write the element to this slot *) + Slot.set_substring t slot ~src ~src_off; + `Ok) + else if Slot.contains_substring t slot ~src ~src_off then `Duplicate + else unguarded_add_substring t (Slot.next t slot) ~src ~src_off + +let resize t = + let old_len = Bigstringaf.length t.data in + let old_data = t.data in + let new_len = old_len + (t.slot_count / 2 * t.elt_length) in + let new_data = Bigstringaf.create new_len in + let old_t = { t with data = old_data; data_length = old_len } in + t.data <- new_data; + t.data_length <- new_len; + t.slot_count <- new_len / t.elt_length; + empty_all_slots t; + Slot.iter_all old_t ~f:(fun old_slot -> + if not (Slot.is_empty old_t old_slot) then + let src_off = Slot.to_offset old_slot in + let new_slot = Slot.of_elt_substring t ~src:old_t.data ~src_off in + let result = + unguarded_add_substring t new_slot ~src:old_t.data ~src_off + in + assert (result = `Ok)) + +(* Resize when the hashset is more than 90% full: *) +let max_load_factor = 0.9 + +let add t elt = + if String.length elt <> t.elt_length then + Fmt.invalid_arg "%s.add: cannot write string of incorrect size to hashset" + __MODULE__; + if String.equal elt t.empty_slot then + Fmt.invalid_arg "%s.add: cannot write null value to hashset" __MODULE__; + + if Float.compare (load_factor t) max_load_factor >= 0 then resize t; + let slot = Slot.of_elt t elt in + let result = unguarded_add t slot elt in + if result = `Ok then t.cardinal <- t.cardinal + 1; + result + +let add_exn t elt = + match add t elt with + | `Ok -> () + | `Duplicate -> + Fmt.invalid_arg "%s.add_exn: element '%S' already present" __MODULE__ elt + +let mem t elt = + if String.length elt <> t.elt_length then + Fmt.invalid_arg "%s.mem: cannot read string of incorrect size from hashset" + __MODULE__; + if String.equal elt t.empty_slot then + Fmt.failwith "%s.mem: cannot read null value from hashset" __MODULE__; + + let rec probe_loop slot = + if Slot.contains t slot elt then true + else if Slot.is_empty t slot then false + else probe_loop (Slot.next t slot) + in + probe_loop (Slot.of_elt t elt) + +let invariant invariant_elt t = + let element_count = ref 0 in + Slot.iter_all t ~f:(fun slot -> + if not (Slot.is_empty t slot) then ( + incr element_count; + invariant_elt (Slot.get t slot))); + assert (t.cardinal = !element_count) + +(* Using [Obj.reachable_words] directly on values of type [t] will give + inaccurate results since bigstrings are allocated on the C heap. As a + workaround, we provide a dedicated [reachable_words] function for use in + benchmarking this implementation. *) +let reachable_words t = + let bytes_per_word = Sys.word_size / 8 in + (t.data_length / bytes_per_word) + Obj.reachable_words (Obj.repr t) diff --git a/vendors/irmin/src/irmin/data/fixed_size_string_set.mli b/vendors/irmin/src/irmin/data/fixed_size_string_set.mli new file mode 100644 index 0000000000000000000000000000000000000000..7633c6cca2259419cc2e5b8f22e7626166667eea --- /dev/null +++ b/vendors/irmin/src/irmin/data/fixed_size_string_set.mli @@ -0,0 +1,60 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type t +(** The type of mutable sets of fixed-length strings. *) + +type elt := string + +val create : + elt_length:int -> + ?initial_slots:int -> + ?hash:(elt -> int) -> + ?hash_substring:(Bigstringaf.t -> off:int -> len:int -> int) -> + ?null:string -> + unit -> + t +(** [create] builds an empty set of fixed-length strings. The parameters are as + follows: + + - [elt_length]: the length of each element string in bytes; + + - [initial_slots]: the minimum number of slots contained in the initial + internal buffer (NOTE: the actual number of slots will be the least power + of two greater than or equal to [initial_buffer]. This is not the same as + the number of elements that can fit inside the buffer, which also depends + on the maximum load factor); + + - [hash] / [hash_substring]: functions to use for placing elements inside + the internal buffer (given that the element is contained in a string or a + bigstring respectively). The stored elements must have uniformly + distributed [hash] results for good performance, and the two hash + functions must be equivalent. Defaults to [Hashtbl.hash] (and an + equivalent function on substrings). + + - [null]: a string of size [elt_length] that is guaranteed to never be added + to the hashset. Passing this string to {!add} or {!mem} after creating the + hashset will result in an exception being raised. *) + +include Hashset.S with type t := t and type elt := elt + +val invariant : (elt -> unit) -> t -> unit +(** [invariant f t] checks the internal invariants of [t] and calls [f] on every + element contained within. Exposed for testing. *) + +val reachable_words : t -> int +(** [reachable_words t] is the total number of words of data kept alive by [t] + (on both the C and OCaml heaps). *) diff --git a/vendors/irmin/src/irmin/data/hashset.ml b/vendors/irmin/src/irmin/data/hashset.ml new file mode 100644 index 0000000000000000000000000000000000000000..d161f46203a3ab696e0940fa3779ced0b085bf4e --- /dev/null +++ b/vendors/irmin/src/irmin/data/hashset.ml @@ -0,0 +1,33 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + type t + type elt + + val add : t -> elt -> [ `Ok | `Duplicate ] + (** [add t elt] adds [elt] to the set [t] and returns [`Ok] if [elt] is not + already a member of [t], otherwise returns [`Duplicate] and leaves the + hashset unchanged. *) + + val add_exn : t -> elt -> unit + (** [add_exn t elt] adds [elt] to the set [t]. + + @raise Invalid_argument if [elt] is already a member of [t]. *) + + val mem : t -> elt -> bool + (** [mem t elt] is [true] iff [elt] has been added to the hashset. *) +end diff --git a/vendors/irmin/src/irmin/data/irmin_data.ml b/vendors/irmin/src/irmin/data/irmin_data.ml new file mode 100644 index 0000000000000000000000000000000000000000..c5eb9283fb337cd59fc78ad72a270bed5d47c69b --- /dev/null +++ b/vendors/irmin/src/irmin/data/irmin_data.ml @@ -0,0 +1,22 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** This module contains data structure implementations used in the + implementation of Irmin. It is exposed only for internal use, and does not + provide a stable API. *) + +module Fixed_size_string_set = Fixed_size_string_set +(** Mutable sets of strings with a common length. *) diff --git a/vendors/irmin/src/irmin/diff.ml b/vendors/irmin/src/irmin/diff.ml new file mode 100644 index 0000000000000000000000000000000000000000..8e0e4d27735c437b9f67d3df03ed924eeb8644a9 --- /dev/null +++ b/vendors/irmin/src/irmin/diff.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type 'a t = [ `Updated of 'a * 'a | `Removed of 'a | `Added of 'a ] +[@@deriving irmin] diff --git a/vendors/irmin/src/irmin/diff.mli b/vendors/irmin/src/irmin/diff.mli new file mode 100644 index 0000000000000000000000000000000000000000..e9b36e6d9a2c8ccbe7a827da84537a508b9c5093 --- /dev/null +++ b/vendors/irmin/src/irmin/diff.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type 'a t = [ `Updated of 'a * 'a | `Removed of 'a | `Added of 'a ] +[@@deriving irmin] +(** The type for representing differences betwen values. *) diff --git a/vendors/irmin/src/irmin/dot.ml b/vendors/irmin/src/irmin/dot.ml new file mode 100644 index 0000000000000000000000000000000000000000..957f0cf508d15e1ccfa009e8d1d140ad293a7ec1 --- /dev/null +++ b/vendors/irmin/src/irmin/dot.ml @@ -0,0 +1,226 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Printf +open Astring + +let src = Logs.Src.create "irmin.dot" ~doc:"Irmin dot graph output" + +module Log = (val Logs.src_log src : Logs.LOG) + +module type S = sig + type db + + val output_buffer : + db -> + ?html:bool -> + ?depth:int -> + ?full:bool -> + date:(int64 -> string) -> + Buffer.t -> + unit Lwt.t +end + +exception Utf8_failure + +let is_valid_utf8 str = + try + Uutf.String.fold_utf_8 + (fun _ _ -> function `Malformed _ -> raise Utf8_failure | _ -> ()) + () str; + true + with Utf8_failure -> false + +module Make (S : Store.Generic_key.S) = struct + type db = S.t + + module Branch = S.Backend.Branch + module Contents = S.Backend.Contents + module Node = S.Backend.Node + module Commit = S.Backend.Commit + module Slice = S.Backend.Slice + + module Graph = + Object_graph.Make (Contents.Hash) (Node.Hash) (Commit.Hash) (Branch.Key) + + module Info = S.Info + + let pp_author = Type.pp Info.author_t + let pp_message = Type.pp Info.message_t + + let fprintf (t : db) ?depth ?(html = false) ?full ~date name = + [%log.debug + "depth=%s html=%b full=%s" + (match depth with None -> "" | Some d -> string_of_int d) + html + (match full with None -> "" | Some b -> string_of_bool b)]; + let* slice = S.Repo.export ?full ?depth (S.repo t) in + let vertex = Hashtbl.create 102 in + let add_vertex v l = Hashtbl.add vertex v l in + let mem_vertex v = Hashtbl.mem vertex v in + let edges = ref [] in + let add_edge v1 l v2 = + if mem_vertex v1 && mem_vertex v2 then edges := (v1, l, v2) :: !edges + in + let string_of_hash t k = + let s = Type.to_string t k in + if String.length s <= 8 then s else String.with_range s ~len:8 + in + let string_of_contents s = + let s = + if String.length s <= 10 then s else String.with_range s ~len:10 + in + let s = if is_valid_utf8 s then s else "" in + s + in + let label_of_node k _ = + let s = + (if html then + sprintf "
%s
" + else fun x -> x) + (string_of_hash Node.Hash.t k) + in + `Label s + in + let label_of_step l = + let l = Type.to_string S.Path.step_t l in + let s = + (if html then sprintf "
%s
" else fun x -> x) + (string_of_contents l) + in + `Label s + in + let label_of_commit k c = + let k = string_of_hash Commit.Hash.t k in + let o = Commit.Val.info c in + let s = + if html then + let message = Fmt.to_to_string pp_message (Info.message o) in + Fmt.str + "
\n\ + \
%s
\n\ + \
%a
\n\ + \
%s
\n\ + \ 
%s
\n\ + \
 
\n\ +
" + k pp_author (Info.author o) + (date (Info.date o)) + (String.Ascii.escape message) + else sprintf "%s" k + in + `Label s + in + let label_of_contents k v = + let k = string_of_hash Contents.Hash.t k in + let s = + if html then + sprintf + "
\n\ + \
%s
\n\ + \
 
\n\ +
" + k + else + let v = string_of_contents (Type.to_string Contents.Val.t v) in + sprintf "%s (%s)" k (String.Ascii.escape_string v) + in + `Label s + in + let label_of_tag t = + let s = + if html then + sprintf "
%s
" (Type.to_string Branch.Key.t t) + else Type.to_string Branch.Key.t t + in + `Label s + in + let contents = ref [] in + let nodes = ref [] in + let commits = ref [] in + let* () = + Slice.iter slice (function + | `Contents c -> + contents := c :: !contents; + Lwt.return_unit + | `Node n -> + nodes := n :: !nodes; + Lwt.return_unit + | `Commit c -> + commits := c :: !commits; + Lwt.return_unit) + in + List.iter + (fun (k, c) -> + add_vertex (`Contents k) [ `Shape `Box; label_of_contents k c ]) + !contents; + List.iter + (fun (k, t) -> + add_vertex (`Node k) [ `Shape `Box; `Style `Dotted; label_of_node k t ]) + !nodes; + List.iter + (fun (k, r) -> + add_vertex (`Commit k) + [ `Shape `Box; `Style `Bold; label_of_commit k r ]) + !commits; + List.iter + (fun (k, t) -> + List.iter + (fun (l, v) -> + match v with + | `Contents (v, _meta) -> + let v = Contents.Key.to_hash v in + add_edge (`Node k) + [ `Style `Dotted; label_of_step l ] + (`Contents v) + | `Node n -> + let n = Node.Key.to_hash n in + add_edge (`Node k) [ `Style `Solid; label_of_step l ] (`Node n)) + (Node.Val.list t)) + !nodes; + List.iter + (fun (k, r) -> + List.iter + (fun c -> + let c = Commit.Key.to_hash c in + add_edge (`Commit k) [ `Style `Bold ] (`Commit c)) + (Commit.Val.parents r); + let node_hash = Commit.Val.node r |> Node.Key.to_hash in + add_edge (`Commit k) [ `Style `Dashed ] (`Node node_hash)) + !commits; + let branch_t = S.Backend.Repo.branch_t (S.repo t) in + let* bs = Branch.list branch_t in + let+ () = + Lwt_list.iter_s + (fun r -> + Branch.find branch_t r >|= function + | None -> () + | Some k -> + let k = Commit.Key.to_hash k in + add_vertex (`Branch r) + [ `Shape `Plaintext; label_of_tag r; `Style `Filled ]; + add_edge (`Branch r) [ `Style `Bold ] (`Commit k)) + bs + in + let vertex = Hashtbl.fold (fun k v acc -> (k, v) :: acc) vertex [] in + fun ppf -> Graph.output ppf vertex !edges name + + let output_buffer t ?html ?depth ?full ~date buf = + let+ fprintf = fprintf t ?depth ?full ?html ~date "graph" in + let ppf = Format.formatter_of_buffer buf in + fprintf ppf +end diff --git a/vendors/irmin/src/irmin/dot.mli b/vendors/irmin/src/irmin/dot.mli new file mode 100644 index 0000000000000000000000000000000000000000..aa8f903461518d1376ca6e3550539bf19b4f81be --- /dev/null +++ b/vendors/irmin/src/irmin/dot.mli @@ -0,0 +1,45 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Store dumps. *) + +module type S = sig + (** {1 Dot Export} *) + + type db + + val output_buffer : + db -> + ?html:bool -> + ?depth:int -> + ?full:bool -> + date:(int64 -> string) -> + Buffer.t -> + unit Lwt.t + (** [output_buffer t ?html ?depth ?full buf] outputs the Graphviz + representation of [t] in the buffer [buf]. + + [html] (default is false) enables HTML labels. + + [depth] is used to limit the depth of the commit history. [None] here + means no limitation. + + If [full] is set (default is not) the full graph, including the commits, + nodes and contents, is exported, otherwise it is the commit history graph + only. *) +end + +module Make (S : Store.Generic_key.S) : S with type db = S.t diff --git a/vendors/irmin/src/irmin/dune b/vendors/irmin/src/irmin/dune new file mode 100644 index 0000000000000000000000000000000000000000..938a2ff5ecd6b1e5910c429612af3dccaf09fb8e --- /dev/null +++ b/vendors/irmin/src/irmin/dune @@ -0,0 +1,22 @@ +(library + (name irmin) + (public_name irmin) + (libraries + irmin.data + astring + bheap + digestif + fmt + jsonm + logs + logs.fmt + lwt + mtime + ocamlgraph + uri + uutf + (re_export repr)) + (preprocess + (pps ppx_irmin.internal -- --lib "Type")) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin/export_for_backends.ml b/vendors/irmin/src/irmin/export_for_backends.ml new file mode 100644 index 0000000000000000000000000000000000000000..507a4913b68c789104bb9dc6605452f2fa6a9d43 --- /dev/null +++ b/vendors/irmin/src/irmin/export_for_backends.ml @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Store_properties = Store_properties +module Logging = Logging +module Reversed_list = Reversed_list +include Import diff --git a/vendors/irmin/src/irmin/hash.ml b/vendors/irmin/src/irmin/hash.ml new file mode 100644 index 0000000000000000000000000000000000000000..37a60e24d56ac17a701794f107d6a13925fb6ac9 --- /dev/null +++ b/vendors/irmin/src/irmin/hash.ml @@ -0,0 +1,123 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Hash_intf + +module Make (H : Digestif.S) = struct + type t = H.t + + external get_64 : string -> int -> int64 = "%caml_string_get64u" + external swap64 : int64 -> int64 = "%bswap_int64" + + let get_64_little_endian str idx = + if Sys.big_endian then swap64 (get_64 str idx) else get_64 str idx + + let short_hash c = Int64.to_int (get_64_little_endian (H.to_raw_string c) 0) + + let short_hash_substring bigstring ~off = + Int64.to_int (Bigstringaf.get_int64_le bigstring off) + + let hash_size = H.digest_size + + let of_hex s = + match H.consistent_of_hex s with + | x -> Ok x + | exception Invalid_argument e -> Error (`Msg e) + + let pp_hex ppf x = Fmt.string ppf (H.to_hex x) + + let t = + Type.map ~pp:pp_hex ~of_string:of_hex + Type.(string_of (`Fixed hash_size)) + H.of_raw_string H.to_raw_string + + let hash s = H.digesti_string s + let to_raw_string s = H.to_raw_string s + let unsafe_of_raw_string s = H.of_raw_string s +end + +module Make_BLAKE2B (D : sig + val digest_size : int +end) = + Make (Digestif.Make_BLAKE2B (D)) + +module Make_BLAKE2S (D : sig + val digest_size : int +end) = + Make (Digestif.Make_BLAKE2S (D)) + +module SHA1 = Make (Digestif.SHA1) +module RMD160 = Make (Digestif.RMD160) +module SHA224 = Make (Digestif.SHA224) +module SHA256 = Make (Digestif.SHA256) +module SHA384 = Make (Digestif.SHA384) +module SHA512 = Make (Digestif.SHA512) +module BLAKE2B = Make (Digestif.BLAKE2B) +module BLAKE2S = Make (Digestif.BLAKE2S) + +module Typed (K : S) (V : Type.S) = struct + include K + + type value = V.t [@@deriving irmin ~pre_hash] + + let hash v = K.hash (pre_hash_value v) +end + +module V1 (K : S) : S with type t = K.t = struct + type t = K.t + + let hash = K.hash + let short_hash = K.short_hash + let short_hash_substring = K.short_hash_substring + let hash_size = K.hash_size + let to_raw_string = K.to_raw_string + let unsafe_of_raw_string = K.unsafe_of_raw_string + let h = Type.string_of `Int64 + let to_bin_key = Type.unstage (Type.to_bin_string K.t) + let of_bin_key = Type.unstage (Type.of_bin_string K.t) + let size_of = Type.Size.using to_bin_key (Type.Size.t h) + + let encode_bin = + let encode_bin = Type.unstage (Type.encode_bin h) in + fun e -> encode_bin (to_bin_key e) + + let decode_bin = + let decode_bin = Type.unstage (Type.decode_bin h) in + fun buf pos_ref -> + let v = decode_bin buf pos_ref in + match of_bin_key v with + | Ok v -> v + | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e + + let t = Type.like K.t ~bin:(encode_bin, decode_bin, size_of) +end + +module Set = struct + module Make (Hash : S) = struct + include Irmin_data.Fixed_size_string_set + + let create ?(initial_slots = 0) () = + let elt_length = Hash.hash_size + and hash s = Hash.(short_hash (unsafe_of_raw_string s)) + and hash_substring t ~off ~len:_ = Hash.short_hash_substring t ~off in + create ~elt_length ~initial_slots ~hash ~hash_substring () + + let add t h = add t (Hash.to_raw_string h) + let mem t h = mem t (Hash.to_raw_string h) + end + + module type S = Set +end diff --git a/vendors/irmin/src/irmin/hash.mli b/vendors/irmin/src/irmin/hash.mli new file mode 100644 index 0000000000000000000000000000000000000000..f9d039dfaac74811a70174bd585b6cbd25d2f113 --- /dev/null +++ b/vendors/irmin/src/irmin/hash.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Hash_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/hash_intf.ml b/vendors/irmin/src/irmin/hash_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..9091fb4ef9db93a36fdc50a95825c0e377133078 --- /dev/null +++ b/vendors/irmin/src/irmin/hash_intf.ml @@ -0,0 +1,133 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** Signature for digest hashes, inspired by Digestif. *) + + type t + (** The type for digest hashes. *) + + val hash : ((string -> unit) -> unit) -> t + (** Compute a deterministic store key from a sequence of strings. *) + + val short_hash : t -> int + (** [short_hash h] is a small hash of [h], to be used for instance as the + `hash` function of an OCaml [Hashtbl]. *) + + val hash_size : int + (** [hash_size] is the size of hash results, in bytes. *) + + val to_raw_string : t -> string + (** [to_raw_string t] is the raw sequence of bytes in [t] (of length + {!hash_size}). *) + + val unsafe_of_raw_string : string -> t + (** [unsafe_of_raw_string b] is the hash consisting of the raw sequence of + bytes [b]. + + {b Warning}: this function cannot guarantee that the supplied byte string + is a valid output of the hash process, so should only be used on strings + that are known to have been built with {!to_raw_string}. *) + + val short_hash_substring : Bigstringaf.t -> off:int -> int + (** [short_hash_substring t off] computes the short-hash of the raw hash data + contained in [t] at offset [off]. It has behaviour equivalent to: + + {[ + Bigstringaf.substring t ~off ~len:hash_size + |> unsafe_of_raw_string + |> short_hash + ]} + + but may be more efficient due to not needing to allocate an intermediate + [string]. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!type-t}. *) +end + +module type Typed = sig + type t + type value + + val hash : value -> t + (** Compute a deterministic store key from a string. *) + + val short_hash : t -> int + (** [short_hash h] is a small hash of [h], to be used for instance as the + `hash` function of an OCaml [Hashtbl]. *) + + val hash_size : int + (** [hash_size] is the size of hash results, in bytes. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!type-t}. *) +end + +module type Set = sig + type t + type hash + + val create : ?initial_slots:int -> unit -> t + val add : t -> hash -> [ `Ok | `Duplicate ] + val mem : t -> hash -> bool +end + +module type Sigs = sig + module type S = S + (** Signature for hash values. *) + + module type Typed = Typed + (** Signature for typed hashes, where [hash] directly takes a value as + argument and incremental hashing is not possible. *) + + (** Digestif hashes. *) + module Make (H : Digestif.S) : S with type t = H.t + + module Make_BLAKE2B (D : sig + val digest_size : int + end) : S + + module Make_BLAKE2S (D : sig + val digest_size : int + end) : S + + module SHA1 : S + module RMD160 : S + module SHA224 : S + module SHA256 : S + module SHA384 : S + module SHA512 : S + module BLAKE2B : S + module BLAKE2S : S + + (** v1 serialisation *) + module V1 (H : S) : S with type t = H.t + + (** Typed hashes. *) + module Typed (K : S) (V : Type.S) : + Typed with type t = K.t and type value = V.t + + module Set : sig + module Make (Hash : S) : Set with type hash := Hash.t + + module type S = Set + end +end diff --git a/vendors/irmin/src/irmin/import.ml b/vendors/irmin/src/irmin/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..db5ff6da0298d14c61ce1893319fef45d0957645 --- /dev/null +++ b/vendors/irmin/src/irmin/import.ml @@ -0,0 +1,148 @@ +(* + * Copyright (c) 2019-2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Extensions to the default namespace, opened throughout the Irmin codebase. *) + +type read = Perms.read +type write = Perms.write +type read_write = Perms.read_write + +(** {2 Lwt syntax} *) + +include Lwt.Syntax + +let ( >>= ) = Lwt.Infix.( >>= ) +let ( >|= ) = Lwt.Infix.( >|= ) + +(** {2 Dependency extensions} *) + +module Option = struct + include Option + (** @closed *) + + let of_result = function Ok x -> Some x | Error _ -> None + let might f = function Some x -> f x | None -> Ok () +end + +module List = struct + include List + (** @closed *) + + let rec is_longer_than : type a. int -> a list -> bool = + fun len l -> + if len < 0 then true + else match l with [] -> false | _ :: tl -> is_longer_than (len - 1) tl + + let map f l = + let rec aux acc = function + | [] -> acc [] + | h :: t -> (aux [@tailcall]) (fun t' -> acc (f h :: t')) t + in + aux (fun x -> x) l + + let concat l = + let rec aux acc curr l = + match (curr, l) with + | [], [] -> List.rev acc + | [], [ l ] -> List.rev_append acc l + | [], h :: t -> (aux [@tailcall]) acc h t + | h :: t, l -> (aux [@tailcall]) (h :: acc) t l + in + aux [] [] l + + (* For compatibility with versions older than ocaml.4.11.0 *) + let concat_map f l = + let rec aux f acc = function + | [] -> rev acc + | x :: l -> + let xs = f x in + aux f (rev_append xs acc) l + in + aux f [] l + + let rec mem : type a. equal:(a -> a -> bool) -> a -> a t -> bool = + fun ~equal y -> function + | [] -> false + | x :: xs -> equal x y || mem ~equal y xs + + let rec rev_append_map : type a b. (a -> b) -> a list -> b list -> b list = + fun f xs ys -> + match xs with [] -> ys | x :: xs -> rev_append_map f xs (f x :: ys) + + let insert_exn : type a. a list -> int -> a -> a list = + fun l idx v -> + (* [list_insert l 0 v] is [v :: l] *) + assert (idx >= 0); + let rec aux l i acc = + if i = 0 then List.rev_append acc (v :: l) + else + match l with + | [] -> failwith "list_insert: input list too short" + | hd :: tl -> aux tl (i - 1) (hd :: acc) + in + aux l idx [] +end + +module Seq = struct + include Seq + (** @closed *) + + let rec drop : type a. int -> a t -> a t = + fun n l () -> + match l () with + | l' when n = 0 -> l' + | Nil -> Nil + | Cons (_, l') -> drop (n - 1) l' () + + let exists : type a. (a -> bool) -> a Seq.t -> bool = + fun f s -> + let rec aux s = + match s () with Seq.Nil -> false | Seq.Cons (v, s) -> f v || aux s + in + aux s + + let rec take : type a. int -> a t -> a t = + fun n l () -> + if n = 0 then Nil + else match l () with Nil -> Nil | Cons (x, l') -> Cons (x, take (n - 1) l') + + let for_all : type a. (a -> bool) -> a Seq.t -> bool = + fun f s -> + let rec aux s = + match s () with Seq.Nil -> true | Seq.Cons (v, s) -> f v && aux s + in + aux s + + (* For compatibility with versions older than ocaml.4.11.0 *) + let rec append seq1 seq2 () = + match seq1 () with + | Nil -> seq2 () + | Cons (x, next) -> Cons (x, append next seq2) +end + +let shuffle state arr = + let rec aux n = + if n > 1 then ( + let k = Random.State.int state (n + 1) in + let temp = arr.(n) in + arr.(n) <- arr.(k); + arr.(k) <- temp; + aux (n - 1)) + in + let len = Array.length arr in + aux (len - 1); + () diff --git a/vendors/irmin/src/irmin/indexable.ml b/vendors/irmin/src/irmin/indexable.ml new file mode 100644 index 0000000000000000000000000000000000000000..6b5bd7d348cf788beb7113088e0cf1818322dcf2 --- /dev/null +++ b/vendors/irmin/src/irmin/indexable.ml @@ -0,0 +1,91 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Indexable_intf + +module Maker_concrete_key2_of_1 (X : Maker_concrete_key1) = struct + type ('h, _) key = 'h X.key + + module Key (H : Hash.S) (_ : Type.S) = X.Key (H) + module Make = X.Make +end + +module Of_content_addressable (Key : Type.S) (S : Content_addressable.S) = +struct + include S + + type hash = key + type key = Key.t + + module Key = struct + include Key + + type nonrec hash = hash + + let to_hash x = x + end + + let index _ h = Lwt.return_some h + let unsafe_add t h v = unsafe_add t h v >|= fun () -> h +end + +module Check_closed (CA : Maker) (Hash : Hash.S) (Value : Type.S) = struct + module S = CA (Hash) (Value) + module Key = S.Key + + type 'a t = { closed : bool ref; t : 'a S.t } + type value = S.value + type key = S.key + type hash = S.hash + + let check_not_closed t = if !(t.closed) then raise Store_properties.Closed + + let mem t k = + check_not_closed t; + S.mem t.t k + + let index t h = + check_not_closed t; + S.index t.t h + + let find t k = + check_not_closed t; + S.find t.t k + + let add t v = + check_not_closed t; + S.add t.t v + + let unsafe_add t k v = + check_not_closed t; + S.unsafe_add t.t k v + + let batch t f = + check_not_closed t; + S.batch t.t (fun w -> f { t = w; closed = t.closed }) + + let v conf = + let+ t = S.v conf in + { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) +end diff --git a/vendors/irmin/src/irmin/indexable.mli b/vendors/irmin/src/irmin/indexable.mli new file mode 100644 index 0000000000000000000000000000000000000000..df5168c32aca89d175dcee31aa2736aa6113d12b --- /dev/null +++ b/vendors/irmin/src/irmin/indexable.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Indexable_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/indexable_intf.ml b/vendors/irmin/src/irmin/indexable_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..e97e6109511848de00ec97eccfa41037aecad673 --- /dev/null +++ b/vendors/irmin/src/irmin/indexable_intf.ml @@ -0,0 +1,136 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Store_properties + +module type S_without_key_impl = sig + include Read_only.S + (** @inline *) + + type hash + (** The type of hashes of [value]. *) + + val add : [> write ] t -> value -> key Lwt.t + (** Write the contents of a value to the store, and obtain its key. *) + + val unsafe_add : [> write ] t -> hash -> value -> key Lwt.t + (** Same as {!add} but allows specifying the value's hash directly. The + backend might choose to discard that hash and/or can be corrupt if the + hash is not consistent. *) + + val index : [> read ] t -> hash -> key option Lwt.t + (** Indexing maps the hash of a value to a corresponding key of that value in + the store. For stores that are addressed by hashes directly, this is + typically [fun _t h -> Lwt.return (Key.of_hash h)]; for stores with more + complex addressing schemes, [index] may attempt a lookup operation in the + store. + + In general, indexing is best-effort and reveals no information about the + membership of the value in the store. In particular: + + - [index t hash = Some key] doesn't guarantee [mem t key]: the value with + hash [hash] may still be absent from the store; + + - [index t hash = None] doesn't guarantee that there is no [key] such that + [mem t key] and [Key.to_hash key = hash]: the value may still be present + in the store under a key that is not indexed. *) + + include Batch with type 'a t := 'a t + (** @inline *) +end + +module type S = sig + (** An {i indexable} store is a read-write store in which values can be added + and later found via their keys. + + Keys are not necessarily portable between different stores, so each store + provides an {!val-index} mechanism to find keys by the hashes of the + values they reference. *) + + include S_without_key_impl (* @inline *) + module Key : Key.S with type t = key and type hash = hash +end + +module type Maker = functor (Hash : Hash.S) (Value : Type.S) -> sig + include S with type value = Value.t and type hash = Hash.t + + include Of_config with type 'a t := 'a t + (** @inline *) +end + +(** A {!Maker_concrete_key} is an indexable store in which the key type is + uniquely determined by the hash type and is stated up-front. *) +module type Maker_concrete_key1 = sig + type 'h key + + module Key : functor (Hash : Hash.S) -> + Key.S with type t = Hash.t key and type hash = Hash.t + + module Make : functor (Hash : Hash.S) (Value : Type.S) -> sig + include + S + with type value = Value.t + and type hash = Hash.t + and type key = Hash.t key + + include Of_config with type 'a t := 'a t + (** @inline *) + end +end + +(** Like {!Maker_concrete_key1}, but the key type may also depend on type of the + value that it references. *) +module type Maker_concrete_key2 = sig + type ('h, 'v) key + + module Key : functor (Hash : Hash.S) (Value : Type.S) -> + Key.S with type t = (Hash.t, Value.t) key and type hash = Hash.t + + module Make : functor (Hash : Hash.S) (Value : Type.S) -> sig + include + S + with type value = Value.t + and type hash = Hash.t + and type key = (Hash.t, Value.t) key + + include Of_config with type 'a t := 'a t + (** @inline *) + end +end + +module type Sigs = sig + module type S = S + module type S_without_key_impl = S_without_key_impl + module type Maker = Maker + module type Maker_concrete_key1 = Maker_concrete_key1 + module type Maker_concrete_key2 = Maker_concrete_key2 + + module Maker_concrete_key2_of_1 (X : Maker_concrete_key1) : + Maker_concrete_key2 with type ('h, _) key = 'h X.key + + module Of_content_addressable + (Key : Type.S) + (S : Content_addressable.S with type key = Key.t) : + S + with type 'a t = 'a S.t + and type key = Key.t + and type hash = Key.t + and type value = S.value + + module Check_closed (M : Maker) : Maker +end diff --git a/vendors/irmin/src/irmin/info.ml b/vendors/irmin/src/irmin/info.ml new file mode 100644 index 0000000000000000000000000000000000000000..9cf6d3404283ec98d75579d1cc975721a4594905 --- /dev/null +++ b/vendors/irmin/src/irmin/info.ml @@ -0,0 +1,41 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Info_intf + +module Default = struct + type author = string [@@deriving irmin] + type message = string [@@deriving irmin] + + type t = { date : int64; author : author; message : message } + [@@deriving irmin ~equal] + + type f = unit -> t + + let empty = { date = 0L; author = ""; message = "" } + let is_empty = equal empty + + let v ?(author = "") ?(message = "") date = + let r = { date; message; author } in + if is_empty r then empty else r + + let date t = t.date + let author t = t.author + let message t = t.message + let none () = empty +end + +type default = Default.t diff --git a/vendors/irmin/src/irmin/info.mli b/vendors/irmin/src/irmin/info.mli new file mode 100644 index 0000000000000000000000000000000000000000..295eedba8339234c77123fed7d81bb03fffd92d6 --- /dev/null +++ b/vendors/irmin/src/irmin/info.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Info_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/info_intf.ml b/vendors/irmin/src/irmin/info_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..2b0dfbf1092d6aa8e244dca489149e81cff981cd --- /dev/null +++ b/vendors/irmin/src/irmin/info_intf.ml @@ -0,0 +1,67 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** {1 Commit Info} *) + +module type S = sig + type author = string [@@deriving irmin] + type message = string [@@deriving irmin] + + type t [@@deriving irmin] + (** The type for commit info. *) + + val v : ?author:author -> ?message:message -> int64 -> t + (** Create a new commit info. *) + + val date : t -> int64 + (** [date t] is [t]'s commit date. + + The date provided by the user when calling the {!v} function. Rounding + [Unix.gettimeofday ()] (when available) is a good value for such date. On + more esoteric platforms, any monotonic counter is a fine value as well. On + the Git backend, the date is translated into the commit {e Date} field and + is expected to be the number of POSIX seconds (thus not counting leap + seconds) since the Epoch. *) + + val author : t -> author + (** [author t] is [t]'s commit author. + + The author identifies the entity (human, unikernel, process, thread, etc) + performing an operation. For the Git backend, this will be directly + translated into the {e Author} field. *) + + val message : t -> message + (** [message t] is [t]'s commit message. *) + + val empty : t + (** The empty commit info. *) + + (** {1 Info Functions} *) + + type f = unit -> t + (** Alias for functions which can build commit info. *) + + val none : f + (** The empty info function. [none ()] is [empty] *) +end + +module type Sigs = sig + module type S = S + + module Default : S + + type default = Default.t +end diff --git a/vendors/irmin/src/irmin/irmin.ml b/vendors/irmin/src/irmin/irmin.ml new file mode 100644 index 0000000000000000000000000000000000000000..e89a09286a1530ba60c49eada3ab1a07c567aca6 --- /dev/null +++ b/vendors/irmin/src/irmin/irmin.ml @@ -0,0 +1,226 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module Type = Repr +module Metrics = Metrics +module Diff = Diff +module Read_only = Read_only +module Append_only = Append_only +module Indexable = Indexable +module Content_addressable = Content_addressable +module Atomic_write = Atomic_write +module Contents = Contents +module Merge = Merge +module Branch = Branch +module Node = Node +module Commit = Commit +module Info = Info +module Schema = Schema +module Dot = Dot.Make +module Hash = Hash +module Path = Path +module Perms = Perms +module Key = Key +module Irmin_node = Node + +exception Closed = Store_properties.Closed + +module type Maker_generic_key_args = sig + module Contents_store : Indexable.Maker_concrete_key2 + module Node_store : Indexable.Maker_concrete_key1 + module Commit_store : Indexable.Maker_concrete_key1 + module Branch_store : Atomic_write.Maker +end + +module Maker_generic_key (Backend : Maker_generic_key_args) = struct + type endpoint = unit + type ('h, 'v) contents_key = ('h, 'v) Backend.Contents_store.key + type 'h node_key = 'h Backend.Node_store.key + type 'h commit_key = 'h Backend.Commit_store.key + + module Make (S : Schema.S) = struct + module X = struct + module Schema = S + module Hash = S.Hash + module Contents_key = Backend.Contents_store.Key (S.Hash) (S.Contents) + module Node_key = Backend.Node_store.Key (S.Hash) + module Commit_key = Backend.Commit_store.Key (S.Hash) + + module Contents = struct + module Backend = Backend.Contents_store.Make (S.Hash) (S.Contents) + include Contents.Store_indexable (Backend) (S.Hash) (S.Contents) + end + + module Node = struct + module Value = + Node.Generic_key.Make (S.Hash) (S.Path) (S.Metadata) (Contents_key) + (Node_key) + + module Backend = Backend.Node_store.Make (S.Hash) (Value) + + include + Node.Generic_key.Store (Contents) (Backend) (S.Hash) (Value) + (S.Metadata) + (S.Path) + end + + module Node_portable = Node.Value.Portable + + module Commit = struct + module Commit_maker = Commit.Generic_key.Maker (Schema.Info) + module Value = Commit_maker.Make (S.Hash) (Node_key) (Commit_key) + module Backend = Backend.Commit_store.Make (S.Hash) (Value) + + include + Commit.Generic_key.Store (S.Info) (Node) (Backend) (S.Hash) (Value) + end + + module Commit_portable = Commit.Value.Portable + + module Branch = struct + module Val = Commit.Key + include Backend.Branch_store (S.Branch) (Val) + module Key = S.Branch + end + + module Slice = Slice.Make (Contents) (Node) (Commit) + module Remote = Remote.None (Commit_key) (S.Branch) + + module Repo = struct + type t = { + config : Conf.t; + contents : read Contents.t; + nodes : read Node.t; + commits : read Commit.t; + branch : Branch.t; + } + + let contents_t t = t.contents + let node_t t = t.nodes + let commit_t t = t.commits + let branch_t t = t.branch + let config t = t.config + + let batch t f = + Contents.Backend.batch t.contents @@ fun c -> + Node.Backend.batch (snd t.nodes) @@ fun n -> + Commit.Backend.batch (snd t.commits) @@ fun ct -> + let contents_t = c in + let node_t = (contents_t, n) in + let commit_t = (node_t, ct) in + f contents_t node_t commit_t + + let v config = + let* contents = Contents.Backend.v config in + let* nodes = Node.Backend.v config in + let* commits = Commit.Backend.v config in + let nodes = (contents, nodes) in + let commits = (nodes, commits) in + let+ branch = Branch.v config in + { contents; nodes; commits; branch; config } + + let close t = + Contents.Backend.close t.contents >>= fun () -> + Node.Backend.close (snd t.nodes) >>= fun () -> + Commit.Backend.close (snd t.commits) >>= fun () -> + Branch.close t.branch + end + end + + include Store.Make (X) + end +end + +module Maker (CA : Content_addressable.Maker) (AW : Atomic_write.Maker) = struct + module Indexable_store = struct + type 'h key = 'h + + module Key = Key.Of_hash + + module Make (Hash : Hash.S) (Value : Type.S) = struct + module CA = Content_addressable.Check_closed (CA) (Hash) (Value) + include Indexable.Of_content_addressable (Hash) (CA) + + let v = CA.v + end + end + + module Maker_args = struct + module Contents_store = Indexable.Maker_concrete_key2_of_1 (Indexable_store) + module Node_store = Indexable_store + module Commit_store = Indexable_store + module Branch_store = Atomic_write.Check_closed (AW) + end + + include Maker_generic_key (Maker_args) +end + +module KV_maker (CA : Content_addressable.Maker) (AW : Atomic_write.Maker) = +struct + type metadata = unit + type hash = Schema.default_hash + + module Maker = Maker (CA) (AW) + include Maker + module Make (C : Contents.S) = Maker.Make (Schema.KV (C)) +end + +module Of_backend = Store.Make + +module type Tree = Tree.S +module type S = Store.S + +type config = Conf.t +type 'a diff = 'a Diff.t + +module type Maker = Store.Maker +module type KV = Store.KV +module type KV_maker = Store.KV_maker + +module Generic_key = struct + include Store.Generic_key + + module type Maker_args = Maker_generic_key_args + + module Maker = Maker_generic_key +end + +module Backend = struct + module Conf = Conf + module Slice = Slice + module Remote = Remote + + module type S = Backend.S + + module Watch = Watch + module Lock = Lock + module Lru = Lru +end + +let version = Version.current + +module Sync = Sync + +type remote = Remote.t = .. + +let remote_store (type t) (module M : Generic_key.S with type t = t) (t : t) = + let module X : Store.Generic_key.S with type t = t = M in + Sync.remote_store (module X) t + +module Metadata = Metadata +module Json_tree = Store.Json_tree +module Export_for_backends = Export_for_backends diff --git a/vendors/irmin/src/irmin/irmin.mli b/vendors/irmin/src/irmin/irmin.mli new file mode 100644 index 0000000000000000000000000000000000000000..ce6251ea3852ff4aa4333c1b72c4e6fb04b40720 --- /dev/null +++ b/vendors/irmin/src/irmin/irmin.mli @@ -0,0 +1,497 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Irmin public API. + + [Irmin] is a library to design and use persistent stores with built-in + snapshot, branching and reverting mechanisms. Irmin uses concepts similar to + {{:http://git-scm.com/} Git} but it exposes them as a high level library + instead of a complex command-line frontend. It features a {e bidirectional} + Git backend, where an application can read and persist its state using the + Git format, fully-compatible with the usual Git tools and workflows. + + Irmin is designed to use a large variety of backends. It is written in pure + OCaml and does not depend on external C stubs; it is thus very portable and + aims to run everywhere, from Linux to browser and MirageOS unikernels. + + Consult the {!examples} of use for a quick start. See also the + {{!Irmin_unix} documentation} for the unix backends. + + {e Release %%VERSION%% - %%HOMEPAGE%%} *) + +val version : string +(** The version of the library. *) + +(** {1 Preliminaries} *) + +module Type = Repr +(** Dynamic types for Irmin values, supplied by + {{:https://github.com/mirage/repr} [Repr]}. These values can be derived from + type definitions via [\[@@deriving irmin\]] (see the + {{:https://github.com/mirage/irmin/blob/main/README_PPX.md} documentation + for [ppx_irmin]})*) + +module Metrics = Metrics +(** Type agnostics mechanisms to manipulate metrics. *) + +module Info = Info +(** Commit info are used to keep track of the origin of write operations in the + stores. [Info] models the metadata associated with commit objects in Git. *) + +module Merge = Merge +(** [Merge] provides functions to build custom 3-way merge operators for various + user-defined contents. *) + +module Diff = Diff +(** Differences between values. *) + +type 'a diff = 'a Diff.t +(** The type for representing differences betwen values. *) + +module Perms = Perms + +(** {1 Low-level Stores} *) + +(** An Irmin store is automatically built from a number of lower-level stores, + each implementing fewer operations, such as {{!Content_addressable.Store} + content-addressable} and {{!Atomic_write.Store} atomic-write} stores. These + low-level stores are provided by various backends. *) + +module Read_only = Read_only +(** Read-only backend backends. *) + +module Append_only = Append_only +(** Append-only backend backends. *) + +module Indexable = Indexable +(** Indexable backend backends. *) + +module Content_addressable = Content_addressable +(** Content-addressable backends. *) + +module Atomic_write = Atomic_write +(** Atomic-write stores. *) + +(** {1 User-Defined Contents} *) + +module Path = Path +(** Store paths. + + An Irmin {{!Irmin.S} store} binds {{!Path.S.t} paths} to user-defined + {{!Contents.S} contents}. Paths are composed by basic elements, that we call + {{!Path.S.step} steps}. The following [Path] module provides functions to + manipulate steps and paths. *) + +module Hash = Hash +(** Hashing functions. + + [Hash] provides user-defined hash functions to digest serialized contents. + Some {{!backend} backends} might be parameterized by such hash functions, + others might work with a fixed one (for instance, the Git format uses only + {{!Hash.SHA1} SHA1}). + + A {{!Hash.SHA1} SHA1} implementation is available to pass to the backends. *) + +module Metadata = Metadata +(** [Metadata] defines metadata that is attached to contents but stored in + nodes. For instance, the Git backend uses this to indicate the type of file + (normal, executable or symlink). *) + +module Contents = Contents +(** [Contents] specifies how user-defined contents need to be {e serializable} + and {e mergeable}. + + The user needs to provide: + + - a type [t] to be used as store contents. + - a value type for [t] (built using the {{!Irmin.Type} Irmin.Type} + combinators). + - a 3-way [merge] function, to handle conflicts between multiple versions of + the same contents. + + Default implementations for {{!Contents.String} idempotent string} and + {{!Contents.Json} JSON} contents are provided. *) + +module Branch = Branch +module Node = Node +module Commit = Commit + +type remote = Remote.t = .. +(** The type for remote stores. *) + +type config = Conf.t +(** The type for backend-specific configuration values. + + Every backend has different configuration options, which are kept abstract + to the user. *) + +(** [Backend] defines functions only useful for creating new backends. If you + are just using the library (and not developing a new backend), you should + not use this module. *) +module Backend : sig + module Conf : module type of Conf + (** Backend configuration. + + A backend configuration is a set of {{!keys} keys} mapping to typed + values. Backends define their own keys. *) + + module Watch = Watch + module Lock = Lock + module Lru = Lru + module Slice = Slice + module Remote = Remote + + module type S = Backend.S + (** The complete collection of backend implementations. *) +end + +module Key = Key + +(** {1 High-level Stores} + + An Irmin store is a branch-consistent store where keys are lists of steps. + + An example is a Git repository where keys are filenames, {e i.e.} lists of + ['/']-separated strings. More complex examples are structured values, where + steps might contain first-class field accessors and array offsets. + + Irmin provides the following features: + + - Support for fast clones, branches and merges, in a fashion very similar to + Git. + - Efficient staging areas for fast, transient, in-memory operations. + - Fast {{!Sync} synchronization} primitives between remote stores, using + native backend protocols (as the Git protocol) when available. *) + +exception Closed +(** The exception raised when any operation is attempted on a closed store, + except for {!S.close}, which is idempotent. *) + +(** Irmin stores. *) +module type S = sig + include Store.S + (** @inline *) +end + +(** [KV] is similar to {!S} but chooses sensible implementations for path and + branch. *) +module type KV = sig + include Store.KV + (** @inline *) +end + +module Json_tree : Store.Json_tree + +module Schema = Schema +(** Store schemas *) + +(** [Maker] is the signature exposed by any backend providing {!S} + implementations. [M] is the implementation of user-defined metadata, [C] is + the one for user-defined contents, [B] is the implementation for branches + and [H] is the implementation for object (blobs, trees, commits) hashes. It + does not use any native synchronization primitives. *) +module type Maker = sig + include Store.Maker + (** @inline *) +end + +(** [KV_maker] is like {!Maker} but where everything except the contents is + replaced by sensible default implementations. *) +module type KV_maker = sig + include Store.KV_maker + (** @inline *) +end + +(** "Generic key" stores are Irmin stores in which the backend may not be keyed + directly by the hashes of stored values. See {!Key} for more details. *) +module Generic_key : sig + include module type of Store.Generic_key + (** @inline *) + + module type Maker_args = sig + module Contents_store : Indexable.Maker_concrete_key2 + module Node_store : Indexable.Maker_concrete_key1 + module Commit_store : Indexable.Maker_concrete_key1 + module Branch_store : Atomic_write.Maker + end + + module Maker (X : Maker_args) : + Maker + with type ('h, 'v) contents_key = ('h, 'v) X.Contents_store.key + and type 'h node_key = 'h X.Node_store.key + and type 'h commit_key = 'h X.Commit_store.key +end + +(** {2 Synchronization} *) + +val remote_store : (module Generic_key.S with type t = 'a) -> 'a -> remote +(** [remote_store t] is the remote corresponding to the local store [t]. + Synchronization is done by importing and exporting store {{!BC.slice} + slices}, so this is usually much slower than native synchronization using + {!Store.remote} but it works for all backends. *) + +module Sync = Sync +(** Remote synchronisation. *) + +(** {1:examples Examples} + + These examples are in the [examples] directory of the distribution. + + {3 Syncing with a remote} + + A simple synchronization example, using the {{!Irmin_unix.Git} Git} backend + and the {!Sync} helpers. The code clones a fresh repository if the + repository does not exist locally, otherwise it performs a fetch: in this + case, only the missing contents are downloaded. + + {[ + open Lwt.Infix + module S = Irmin_unix.Git.FS.KV (Irmin.Contents.String) + module Sync = Irmin.Sync (S) + + let config = Irmin_git.config "/tmp/test" + + let upstream = + if Array.length Sys.argv = 2 then + Uri.of_string (Store.remote Sys.argv.(1)) + else ( + Printf.eprintf "Usage: sync [uri]\n%!"; + exit 1) + + let test () = + S.Repo.v config >>= S.main >>= fun t -> + Sync.pull_exn t upstream `Set >>= fun () -> + S.get t [ "README.md" ] >|= fun r -> Printf.printf "%s\n%!" r + + let () = Lwt_main.run (test ()) + ]} + + {3 Mergeable logs} + + The complete code for the following can be found in + [examples/custom_merge.ml]. + + We will demonstrate the use of custom merge operators by defining mergeable + debug log files. We first define a log entry as a pair of a timestamp and a + message, using the combinator exposed by {!Irmin.Type}: + + {[ + open Lwt.Infix + open Astring + + let time = ref 0L + let failure fmt = Fmt.kstr failwith fmt + + (* A log entry *) + module Entry : sig + include Irmin.Type.S + + val v : string -> t + val timestamp : t -> int64 + end = struct + type t = { timestamp : int64; message : string } [@@deriving irmin] + + let compare x y = Int64.compare x.timestamp y.timestamp + + let v message = + time := Int64.add 1L !time; + { timestamp = !time; message } + + let timestamp t = t.timestamp + + let pp ppf { timestamp; message } = + Fmt.pf ppf "%04Ld: %s" timestamp message + + let of_string str = + match String.cut ~sep:": " str with + | None -> Error (`Msg ("invalid entry: " ^ str)) + | Some (x, message) -> ( + try Ok { timestamp = Int64.of_string x; message } + with Failure e -> Error (`Msg e)) + + let t = Irmin.Type.like ~pp ~of_string ~compare t + end + ]} + + A log file is a list of entries (one per line), ordered by decreasing order + of timestamps. The 3-way [merge] operator for log files concatenates and + sorts the new entries and prepend them to the common ancestor's ones. + + {[ + (* A log file *) + module Log : sig + include Irmin.Contents.S + + val add : t -> Entry.t -> t + val empty : t + end = struct + type t = Entry.t list [@@deriving irmin] + + let empty = [] + let pp_entry = Irmin.Type.pp Entry.t + let lines ppf l = List.iter (Fmt.pf ppf "%a\n" pp_entry) (List.rev l) + + let of_string str = + let lines = String.cuts ~empty:false ~sep:"\n" str in + try + List.fold_left + (fun acc l -> + match Irmin.Type.of_string Entry.t l with + | Ok x -> x :: acc + | Error (`Msg e) -> failwith e) + [] lines + |> fun l -> Ok l + with Failure e -> Error (`Msg e) + + let t = Irmin.Type.like ~pp:lines ~of_string t + let timestamp = function [] -> 0L | e :: _ -> Entry.timestamp e + + let newer_than timestamp file = + let rec aux acc = function + | [] -> List.rev acc + | h :: _ when Entry.timestamp h <= timestamp -> List.rev acc + | h :: t -> aux (h :: acc) t + in + aux [] file + + let merge ~old t1 t2 = + let open Irmin.Merge.Infix in + old () >>=* fun old -> + let old = match old with None -> [] | Some o -> o in + let ts = timestamp old in + let t1 = newer_than ts t1 in + let t2 = newer_than ts t2 in + let t3 = + List.sort (Irmin.Type.compare Entry.t) (List.rev_append t1 t2) + in + Irmin.Merge.ok (List.rev_append t3 old) + + let merge = Irmin.Merge.(option (v t merge)) + let add t e = e :: t + end + ]} + + {b Note:} The serialisation primitives used in that example are not very + efficient in this case as they parse the file every time. For real usage, + you would write buffered versions of [Log.pp] and [Log.of_string]. + + To persist the log file on disk, we need to choose a backend. We show here + how to use the on-disk [Git] backend on Unix. + + {[ + (* Build an Irmin store containing log files. *) + module Store = Irmin_unix.Git.FS.KV (Log) + + (* Set-up the local configuration of the Git repository. *) + let config = Irmin_git.config ~bare:true Config.root + + (* Convenient alias for the info function for commit messages *) + let info = Irmin_unix.info + ]} + + We can now define a toy example to use our mergeable log files. + + {[ + let log_file = [ "local"; "debug" ] + + let all_logs t = + Store.find t log_file >|= function None -> Log.empty | Some l -> l + + (** Persist a new entry in the log. Pretty inefficient as it reads/writes + the whole file every time. *) + let log t fmt = + Printf.ksprintf + (fun message -> + all_logs t >>= fun logs -> + let logs = Log.add logs (Entry.v message) in + Store.set_exn t ~info:(info "Adding a new entry") log_file logs) + fmt + + let print_logs name t = + all_logs t >|= fun logs -> + Fmt.pr "-----------\n%s:\n-----------\n%a%!" name (Irmin.Type.pp Log.t) + logs + + let main () = + Config.init (); + Store.Repo.v config >>= fun repo -> + Store.main repo >>= fun t -> + (* populate the log with some random messages *) + Lwt_list.iter_s + (fun msg -> log t "This is my %s " msg) + [ "first"; "second"; "third" ] + >>= fun () -> + Printf.printf "%s\n\n" what; + print_logs "lca" t >>= fun () -> + Store.clone ~src:t ~dst:"test" >>= fun x -> + log x "Adding new stuff to x" >>= fun () -> + log x "Adding more stuff to x" >>= fun () -> + log x "More. Stuff. To x." >>= fun () -> + print_logs "branch 1" x >>= fun () -> + log t "I can add stuff on t also" >>= fun () -> + log t "Yes. On t!" >>= fun () -> + print_logs "branch 2" t >>= fun () -> + Store.merge_into ~info:(info "Merging x into t") x ~into:t >>= function + | Ok () -> print_logs "merge" t + | Error _ -> failwith "conflict!" + + let () = Lwt_main.run (main ()) + ]} *) + +(** {1 Helpers} *) + +(** [Dot] provides functions to export a store to the Graphviz `dot` format. *) +module Dot (S : Generic_key.S) : Dot.S with type db = S.t + +(** {1:backend Backends} + + API to create new Irmin backends. A backend is an implementation exposing + either a concrete implementation of {!S} or a functor providing {!S} once + applied. + + There are two ways to create a concrete {!Irmin.S} implementation: + + - {!Make} creates a store where all the objects are stored in the same + store, using the same internal keys format and a custom binary format + based on {{:https://github.com/janestreet/bin_prot} bin_prot}, with no + native synchronization primitives: it is usually what is needed to quickly + create a new backend. + - {!Make_ext} creates a store with a {e deep} embedding of each of the + internal stores into separate store, with total control over the binary + format and using the native synchronization protocols when available. *) + +(** Simple store creator. Use the same type of all of the internal keys and + store all the values in the same store. *) +module Maker (CA : Content_addressable.Maker) (AW : Atomic_write.Maker) : + Maker with type endpoint = unit + +module KV_maker (CA : Content_addressable.Maker) (AW : Atomic_write.Maker) : + KV_maker with type endpoint = unit and type metadata = unit + +(** Advanced store creator. *) +module Of_backend (B : Backend.S) : + Generic_key.S + with module Schema = B.Schema + and type repo = B.Repo.t + and type slice = B.Slice.t + and type contents_key = B.Contents.Key.t + and type node_key = B.Node.Key.t + and type commit_key = B.Commit.Key.t + and module Backend = B + +module Export_for_backends = Export_for_backends +(** Helper module containing useful top-level types for defining Irmin backends. + This module is relatively unstable. *) diff --git a/vendors/irmin/src/irmin/key.ml b/vendors/irmin/src/irmin/key.ml new file mode 100644 index 0000000000000000000000000000000000000000..c7b86c388e3bb4707da453a9a8ecc646660a613d --- /dev/null +++ b/vendors/irmin/src/irmin/key.ml @@ -0,0 +1,25 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Key_intf + +module Of_hash (Hash : Type.S) = struct + type t = Hash.t [@@deriving irmin] + type hash = Hash.t + + let to_hash x = x [@@inline] + let of_hash x = x [@@inline] +end diff --git a/vendors/irmin/src/irmin/key.mli b/vendors/irmin/src/irmin/key.mli new file mode 100644 index 0000000000000000000000000000000000000000..dc5b25d5470cf62dcd8e4c4d5162453f06a9d2af --- /dev/null +++ b/vendors/irmin/src/irmin/key.mli @@ -0,0 +1,92 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Module types for {i keys} into an arbitrary store. + + {2 Choices of key representation} + + {3 Hash-like keys} + + Most Irmin stores are keyed directly by a {i hash} of the values that they + store. This results in a so-called "content-addressable" store, in which all + possible contents values have exactly one key. The key is derived from the + value via [hash] and, given a key, the corresponding value can be retrieved + from the store via [find]: + + {[ + ┌───────────────────────────────┐ + │ │ + ┌───────┐ v find ┌───────┐ hash ┌─────┐ + │ Store │ ──> (+) ──────> │ Value │ ──────> │ Key │ + └───────┘ └───────┘ └─────┘ + ]} + + Keys built this way – with a 1:1 correspondence between the key and the + hash, are known as {!Hash_like}. This class of key representation has some + important properties: + + - {b irredundant storage}: given that an object's key is derived directly + from its representation, there can be at most one copy of any content + value in the store at one time – the store is naturally free of + duplicates. + + - {b reproducibility}: again, because keys are derived directly from values, + multiple parties are guaranteed to compute the same store keys for a given + set of stored values. + + However, it also has some disadvantages. Implementing a hash-keyed store + requires some mechanism for mapping hashes to their physical location (e.g. + their offset on disk), called an "index". This auxiliary index occupies + space, and must be queried for each pointer in the store (even for internal + pointers between nodes along a path). + + {3 Non-hash-like keys} + + For this reason, Irmin allows backends to supply custom key representations + that do not satisfy the above properties (i.e. not irredundant, and not + reproducible). This leads to the following more complex set of relationships + between the values: + + {[ + ┌────────────────────────────────────────────────────────┐ + │ │ + ┌············┼··········································┐ │ + : │ : │ + ┌───────┐ v find ┌───────┐ hash ┌──────┐ v index ┌─────┐ + │ Store │ ──> (+) ──────> │ Value │ ──────> │ Hash │ ··> (+) ·······> │ Key │ + └───────┘ └───────┘ └──────┘ └─────┘ + │ v ∧ to_hash │ ^ + └───────────────────────> (+) └────────────────────────┘ │ + │ add │ + └────────────────────────────────────────────┘ + ]} + + In general, the key of a value isn't known until it has been added to a + particular store, and keys need not be portable between different stores. + It's still required that keys be convertible to hashes, as this ensures the + consistency of Irmin's Merkle tree structure. + + Stores that use non-hash-like keys are not content-addressable, since the + user can't compute the key of a value given the value itself (and perhaps a + value has more than one possible key). + + Implementer's note: all key implementations must have a pre-hash + implementation derived in terms of [Key.to_hash]. That is, for all keys [k], + given [h = Key.to_hash k] then [Irmin.Type.pre_hash key_t k] must equal + [Irmin.Type.pre_hash hash_t h]. *) + +include Key_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/key_intf.ml b/vendors/irmin/src/irmin/key_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..3a1539102b81616a3792434c2bf9f647e86ecbe5 --- /dev/null +++ b/vendors/irmin/src/irmin/key_intf.ml @@ -0,0 +1,62 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + type t [@@deriving irmin] + (** The type for keys. *) + + type hash + + val to_hash : t -> hash +end + +module type Hash_like = sig + include S + + val of_hash : hash -> t +end + +module Store_spec = struct + module type S = sig + type ('h, 'v) contents_key + type 'h node_key + type 'h commit_key + end + + module type Hash_keyed = + S + with type ('h, _) contents_key = 'h + and type 'h node_key = 'h + and type 'h commit_key = 'h + + module rec Hash_keyed : Hash_keyed = Hash_keyed +end + +module type Sigs = sig + module type S = S + module type Hash_like = Hash_like + + (** The simplest possible [Key] implementation is just a hash of the + corresponding value, attaching no additional metadata about the value. *) + module Of_hash (H : Type.S) : Hash_like with type t = H.t and type hash = H.t + + module Store_spec : sig + module type S = Store_spec.S + module type Hash_keyed = Store_spec.Hash_keyed + + module Hash_keyed : Hash_keyed + end +end diff --git a/vendors/irmin/src/irmin/lock.ml b/vendors/irmin/src/irmin/lock.ml new file mode 100644 index 0000000000000000000000000000000000000000..6cd3f5a0abfb5c4402f20d92956c5bd81f6dd97f --- /dev/null +++ b/vendors/irmin/src/irmin/lock.ml @@ -0,0 +1,66 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + type key + type t + + val v : unit -> t + val with_lock : t -> key -> (unit -> 'a Lwt.t) -> 'a Lwt.t + val stats : t -> int +end + +module Make (K : Type.S) = struct + module K = struct + type t = K.t + + let hash = Hashtbl.hash + let equal = Type.(unstage (equal K.t)) + end + + module KHashtbl = Hashtbl.Make (K) + + type key = K.t + type t = { global : Lwt_mutex.t; locks : Lwt_mutex.t KHashtbl.t } + + let v () = { global = Lwt_mutex.create (); locks = KHashtbl.create 1024 } + let stats t = KHashtbl.length t.locks + + let lock t key () = + let lock = + try KHashtbl.find t.locks key + with Not_found -> + let lock = Lwt_mutex.create () in + KHashtbl.add t.locks key lock; + lock + in + Lwt.return lock + + let unlock t key () = + let () = + if KHashtbl.mem t.locks key then + let lock = KHashtbl.find t.locks key in + if Lwt_mutex.is_empty lock then KHashtbl.remove t.locks key + in + Lwt.return_unit + + let with_lock t k fn = + let* lock = Lwt_mutex.with_lock t.global (lock t k) in + let* r = Lwt_mutex.with_lock lock fn in + Lwt_mutex.with_lock t.global (unlock t k) >>= fun () -> Lwt.return r +end diff --git a/vendors/irmin/src/irmin/lock.mli b/vendors/irmin/src/irmin/lock.mli new file mode 100644 index 0000000000000000000000000000000000000000..718b6db22b29918d6b6e8b9dfae53e53878cb307 --- /dev/null +++ b/vendors/irmin/src/irmin/lock.mli @@ -0,0 +1,37 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** {1 Process locking helpers} *) + +module type S = sig + type t + (** The type for lock manager. *) + + type key + (** The type for key to be locked. *) + + val v : unit -> t + (** Create a lock manager. *) + + val with_lock : t -> key -> (unit -> 'a Lwt.t) -> 'a Lwt.t + (** [with_lock t k f] executes [f ()] while holding the exclusive lock + associated to the key [k]. *) + + val stats : t -> int +end + +(** Create a lock manager implementation. *) +module Make (K : Type.S) : S with type key = K.t diff --git a/vendors/irmin/src/irmin/logging.ml b/vendors/irmin/src/irmin/logging.ml new file mode 100644 index 0000000000000000000000000000000000000000..f398ae412f5e0d4ee392f9fa17e1ac945dfce302 --- /dev/null +++ b/vendors/irmin/src/irmin/logging.ml @@ -0,0 +1,61 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Logging_intf +module Source_code_position = Ppx_irmin_internal_lib.Source_code_position + +(** A logs reporter that is aware of the tags added by [ppx_irmin.internal]. *) +let reporter : + ?filter_src:(Logs.src -> bool) -> + ?prefix:string -> + (module Clock) -> + Logs.reporter = + fun ?(filter_src = Fun.const true) ?(prefix = "") (module Clock) -> + let pad n x = + if String.length x > n then x else x ^ String.make (n - String.length x) ' ' + in + let start_time = Clock.counter () in + let report src level ~over k msgf = + let k _ = + over (); + k () + in + let ppf = match level with Logs.App -> Fmt.stdout | _ -> Fmt.stderr in + let with_stamp h tags k fmt = + let dt = Mtime.Span.to_us (Clock.count start_time) in + let source_pos_text, source_pos_colour = + match tags with + | None -> (Logs.Src.name src, `Magenta) + | Some tags -> + let text = + Logs.Tag.find Source_code_position.tag tags + |> Option.fold ~none:"" ~some:(fun (fname, lnum, _, _) -> + Fmt.str "%s:%d" fname lnum) + in + (text, `Faint) + in + Fmt.kpf k ppf + ("%s%+04.0fus %a %a @[" ^^ fmt ^^ "@]@.") + prefix dt + Fmt.(styled source_pos_colour string) + (pad 35 source_pos_text) Logs_fmt.pp_header (level, h) + in + msgf @@ fun ?header ?tags fmt -> + if filter_src src then with_stamp header tags k fmt + else Format.ikfprintf k ppf fmt + in + { Logs.report } diff --git a/vendors/irmin/src/irmin/logging.mli b/vendors/irmin/src/irmin/logging.mli new file mode 100644 index 0000000000000000000000000000000000000000..b86bdac8c8b90e2d9720757ca36ed04b5b351a91 --- /dev/null +++ b/vendors/irmin/src/irmin/logging.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Logging_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/logging_intf.ml b/vendors/irmin/src/irmin/logging_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..703fde55cb5f8b3a1eb9be8ac592cd83c0a62fad --- /dev/null +++ b/vendors/irmin/src/irmin/logging_intf.ml @@ -0,0 +1,48 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type Clock = sig + (** A monotonic time source. See {!Mtime_clock} for an OS-dependent + implementation. *) + + type counter + + val counter : unit -> counter + val count : counter -> Mtime.span +end + +module type Sigs = sig + (** {!Logs} tags attached to the log entries emitted by Irmin: *) + + module Source_code_position : sig + type t = string * int * int * int + (** The type of iclusive ranges of source code positions, as generated by + the OCaml {!val-Stdlib.__POS__} macro. The 4-tuple components are 'file + name', 'line number', 'column start' and 'column end' respectively. *) + + val pp : t Fmt.t + val tag : t Logs.Tag.def + end + + module type Clock = Clock + + val reporter : + ?filter_src:(Logs.src -> bool) -> + ?prefix:string -> + (module Clock) -> + Logs.reporter + (** A default {!Logs} reporter that is sensitive to the logs tags above. *) +end diff --git a/vendors/irmin/src/irmin/lru.ml b/vendors/irmin/src/irmin/lru.ml new file mode 100644 index 0000000000000000000000000000000000000000..67990bb062a89fd286f8f0608da60080dd0e67bf --- /dev/null +++ b/vendors/irmin/src/irmin/lru.ml @@ -0,0 +1,126 @@ +(* + Copyright (c) 2016 David Kaloper Meršinjak + + Permission to use, copy, modify, and/or distribute this software for any + purpose with or without fee is hereby granted, provided that the above + copyright notice and this permission notice appear in all copies. + + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) + +(* Extracted from https://github.com/pqwy/lru *) + +module Make (H : Hashtbl.HashedType) = struct + module HT = Hashtbl.Make (H) + + module Q = struct + type 'a node = { + value : 'a; + mutable next : 'a node option; + mutable prev : 'a node option; + } + + type 'a t = { + mutable first : 'a node option; + mutable last : 'a node option; + } + + let detach t n = + let np = n.prev and nn = n.next in + (match np with + | None -> t.first <- nn + | Some x -> + x.next <- nn; + n.prev <- None); + match nn with + | None -> t.last <- np + | Some x -> + x.prev <- np; + n.next <- None + + let append t n = + let on = Some n in + match t.last with + | Some x as l -> + x.next <- on; + t.last <- on; + n.prev <- l + | None -> + t.first <- on; + t.last <- on + + let node x = { value = x; prev = None; next = None } + let create () = { first = None; last = None } + + let clear t = + t.first <- None; + t.last <- None + end + + type key = HT.key + + type 'a t = { + ht : (key * 'a) Q.node HT.t; + q : (key * 'a) Q.t; + mutable cap : int; + mutable w : int; + } + + let weight t = t.w + let create cap = { cap; w = 0; ht = HT.create cap; q = Q.create () } + + let drop_lru t = + match t.q.first with + | None -> () + | Some ({ Q.value = k, _; _ } as n) -> + t.w <- t.w - 1; + HT.remove t.ht k; + Q.detach t.q n + + let remove t k = + try + let n = HT.find t.ht k in + t.w <- t.w - 1; + HT.remove t.ht k; + Q.detach t.q n + with Not_found -> () + + let add t k v = + if t.cap = 0 then () + else ( + remove t k; + let n = Q.node (k, v) in + t.w <- t.w + 1; + if weight t > t.cap then drop_lru t; + HT.add t.ht k n; + Q.append t.q n) + + let promote t k = + try + let n = HT.find t.ht k in + Q.( + detach t.q n; + append t.q n) + with Not_found -> () + + let find t k = + let v = HT.find t.ht k in + promote t k; + snd v.value + + let mem t k = + match HT.mem t.ht k with + | false -> false + | true -> + promote t k; + true + + let clear t = + HT.clear t.ht; + Q.clear t.q +end diff --git a/vendors/irmin/src/irmin/lru.mli b/vendors/irmin/src/irmin/lru.mli new file mode 100644 index 0000000000000000000000000000000000000000..f25e87db67599907d524f914e37e31a73e40b341 --- /dev/null +++ b/vendors/irmin/src/irmin/lru.mli @@ -0,0 +1,26 @@ +(* + Copyright (c) 2016 David Kaloper Meršinjak + + Permission to use, copy, modify, and/or distribute this software for any + purpose with or without fee is hereby granted, provided that the above + copyright notice and this permission notice appear in all copies. + + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) + +(* Extracted from https://github.com/pqwy/lru *) + +module Make (H : Hashtbl.HashedType) : sig + type 'a t + + val create : int -> 'a t + val add : 'a t -> H.t -> 'a -> unit + val find : 'a t -> H.t -> 'a + val mem : 'a t -> H.t -> bool + val clear : 'a t -> unit +end diff --git a/vendors/irmin/src/irmin/mem/dune b/vendors/irmin/src/irmin/mem/dune new file mode 100644 index 0000000000000000000000000000000000000000..e667c80c957c0b966639d391fb120637de38864b --- /dev/null +++ b/vendors/irmin/src/irmin/mem/dune @@ -0,0 +1,6 @@ +(library + (name irmin_mem) + (public_name irmin.mem) + (libraries irmin logs lwt) + (preprocess + (pps ppx_irmin.internal))) diff --git a/vendors/irmin/src/irmin/mem/import.ml b/vendors/irmin/src/irmin/mem/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..71053e21ba54118af9da1fc7b37d45eb620c46e2 --- /dev/null +++ b/vendors/irmin/src/irmin/mem/import.ml @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/src/irmin/mem/irmin_mem.ml b/vendors/irmin/src/irmin/mem/irmin_mem.ml new file mode 100644 index 0000000000000000000000000000000000000000..e69eefa1af1708e15359cc273fb982f2be3a1b56 --- /dev/null +++ b/vendors/irmin/src/irmin/mem/irmin_mem.ml @@ -0,0 +1,167 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +let src = Logs.Src.create "irmin.mem" ~doc:"Irmin in-memory store" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Conf = struct + include Irmin.Backend.Conf + + let spec = Spec.v "mem" + let root config = find_root config |> Option.value ~default:"." +end + +module Read_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct + module KMap = Map.Make (struct + type t = K.t + + let compare = Irmin.Type.(unstage (compare K.t)) + end) + + type key = K.t + type value = V.t + type 'a t = { mutable t : value KMap.t; root : string } + + let new_instance root = { t = KMap.empty; root } + + let v = + let cache : (string, 'a t) Hashtbl.t = Hashtbl.create 0 in + fun config -> + let root = Conf.root config in + let t = + match Hashtbl.find_opt cache root with + | None -> + let t = new_instance root in + Hashtbl.add cache root t; + t + | Some t -> t + in + Lwt.return t + + let clear t = + [%log.debug "clear"]; + t.t <- KMap.empty; + Lwt.return_unit + + let close _ = + [%log.debug "close"]; + Lwt.return_unit + + let cast t = (t :> read_write t) + let batch t f = f (cast t) + let pp_key = Irmin.Type.pp K.t + + let find { t; _ } key = + [%log.debug "find %a" pp_key key]; + try Lwt.return_some (KMap.find key t) with Not_found -> Lwt.return_none + + let mem { t; _ } key = + [%log.debug "mem %a" pp_key key]; + Lwt.return (KMap.mem key t) +end + +module Append_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct + include Read_only (K) (V) + + let add t key value = + [%log.debug "add -> %a" pp_key key]; + t.t <- KMap.add key value t.t; + Lwt.return_unit +end + +module Atomic_write (K : Irmin.Type.S) (V : Irmin.Type.S) = struct + module RO = Read_only (K) (V) + module W = Irmin.Backend.Watch.Make (K) (V) + module L = Irmin.Backend.Lock.Make (K) + + type t = { t : unit RO.t; w : W.t; lock : L.t } + type key = RO.key + type value = RO.value + type watch = W.watch + + let watches = W.v () + let lock = L.v () + + let v config = + let* t = RO.v config in + Lwt.return { t; w = watches; lock } + + let close t = W.clear t.w >>= fun () -> RO.close t.t + let find t = RO.find t.t + let mem t = RO.mem t.t + let watch_key t = W.watch_key t.w + let watch t = W.watch t.w + let unwatch t = W.unwatch t.w + + let list t = + [%log.debug "list"]; + RO.KMap.fold (fun k _ acc -> k :: acc) t.t.RO.t [] |> Lwt.return + + let set t key value = + [%log.debug "update"]; + let* () = + L.with_lock t.lock key (fun () -> + t.t.RO.t <- RO.KMap.add key value t.t.RO.t; + Lwt.return_unit) + in + W.notify t.w key (Some value) + + let remove t key = + [%log.debug "remove"]; + let* () = + L.with_lock t.lock key (fun () -> + t.t.RO.t <- RO.KMap.remove key t.t.RO.t; + Lwt.return_unit) + in + W.notify t.w key None + + let equal_v_opt = Irmin.Type.(unstage (equal (option V.t))) + + let test_and_set t key ~test ~set = + [%log.debug "test_and_set"]; + let* updated = + L.with_lock t.lock key (fun () -> + let+ v = find t key in + if equal_v_opt test v then + let () = + match set with + | None -> t.t.RO.t <- RO.KMap.remove key t.t.RO.t + | Some v -> t.t.RO.t <- RO.KMap.add key v t.t.RO.t + in + true + else false) + in + let+ () = if updated then W.notify t.w key set else Lwt.return_unit in + updated + + let clear t = W.clear t.w >>= fun () -> RO.clear t.t +end + +let config () = Conf.empty Conf.spec + +module Content_addressable = Irmin.Content_addressable.Make (Append_only) +module S = Irmin.Maker (Content_addressable) (Atomic_write) +module KV = Irmin.KV_maker (Content_addressable) (Atomic_write) +include S + +(* Enforce that {!S} is a sub-type of {!Irmin.Maker}. *) +module Maker_is_a_maker : Irmin.Maker = S + +(* Enforce that {!KV} is a sub-type of {!Irmin.KV_maker}. *) +module KV_is_a_KV : Irmin.KV_maker = KV diff --git a/vendors/irmin/src/irmin/mem/irmin_mem.mli b/vendors/irmin/src/irmin/mem/irmin_mem.mli new file mode 100644 index 0000000000000000000000000000000000000000..b458f2a182b8ef451cadd249c8166554c7dfc689 --- /dev/null +++ b/vendors/irmin/src/irmin/mem/irmin_mem.mli @@ -0,0 +1,43 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** In-memory store. + + A simple in-memory store, using hash tables. Once one of the functors below + is instantiated to a module [M], it has a unique shared hash-table: multiple + invocation of [M.create] will see and manipulate the same contents. *) + +module Conf : sig + val spec : Irmin.Backend.Conf.Spec.t +end + +val config : unit -> Irmin.config +(** Configuration values. *) + +module Append_only : Irmin.Append_only.Maker +(** An in-memory store for append-only values. *) + +module Content_addressable : Irmin.Content_addressable.Maker +(** An in-memory store for content-addressable values. *) + +module Atomic_write : Irmin.Atomic_write.Maker +(** An in-memory store with atomic-write guarantees. *) + +(** Constructor for in-memory KV stores. *) +module KV : Irmin.KV_maker with type endpoint = unit and type metadata = unit + +include Irmin.Maker with type endpoint = unit +(** Constructor for in-memory Irmin store. *) diff --git a/vendors/irmin/src/irmin/merge.ml b/vendors/irmin/src/irmin/merge.ml new file mode 100644 index 0000000000000000000000000000000000000000..67435d80e95a4b02bd6c7492f4ca1bef23971593 --- /dev/null +++ b/vendors/irmin/src/irmin/merge.ml @@ -0,0 +1,421 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Printf + +let src = Logs.Src.create "irmin.merge" ~doc:"Irmin merging" + +module Log = (val Logs.src_log src : Logs.LOG) + +type conflict = [ `Conflict of string ] +type 'a promise = unit -> ('a option, conflict) result Lwt.t + +let promise t : 'a promise = fun () -> Lwt.return (Ok (Some t)) + +let memo fn = + let r = ref None in + fun () -> + match !r with + | Some x -> x + | None -> + let* x = fn () in + r := Some (Lwt.return x); + Lwt.return x + +type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t +type 'a t = 'a Type.t * 'a f + +let v t f = (t, f) +let f (x : 'a t) = snd x + +let conflict fmt = + ksprintf + (fun msg -> + [%log.debug "conflict: %s" msg]; + Lwt.return (Error (`Conflict msg))) + fmt + +let bind x f = x >>= function Error e -> Lwt.return (Error e) | Ok x -> f x +let map f x = x >|= function Error _ as x -> x | Ok x -> Ok (f x) + +let map_promise f t () = + t () >|= function + | Error _ as x -> x + | Ok None -> Ok None + | Ok (Some a) -> Ok (Some (f a)) + +let bind_promise t f () = + t () >>= function + | Error e -> Lwt.return (Error e) + | Ok None -> Lwt.return (Ok None) + | Ok (Some a) -> f a () + +let ok x = Lwt.return (Ok x) + +module Infix = struct + let ( >>=* ) = bind + let ( >|=* ) x f = map f x + let ( >>=? ) = bind_promise + let ( >|=? ) x f = map_promise f x +end + +open Infix + +let default (type a) (t : a Type.t) : a t = + let pp = Type.pp t and equal = Type.(unstage (equal t)) in + ( t, + fun ~old t1 t2 -> + let open Infix in + [%log.debug "default %a | %a" pp t1 pp t2]; + old () >>=* function + | None -> conflict "default: add/add and no common ancestor" + | Some old -> + [%log.debug "default old=%a" pp t1]; + if equal old t1 && equal t1 t2 then ok t1 + else if equal old t1 then ok t2 + else if equal old t2 then ok t1 + else conflict "default" ) + +let idempotent dt = + let equal = Type.(unstage (equal dt)) in + let default = default dt in + let f ~old x y = if equal x y then ok x else f default ~old x y in + v dt f + +let seq = function + | [] -> invalid_arg "nothing to merge" + | (t, _) :: _ as ts -> + ( t, + fun ~old v1 v2 -> + Lwt_list.fold_left_s + (fun acc (_, merge) -> + match acc with Ok x -> ok x | Error _ -> merge ~old v1 v2) + (Error (`Conflict "nothing to merge")) + ts ) + +let option (type a) ((a, t) : a t) : a option t = + let pp_a = Type.pp a and equal = Type.(unstage (equal a)) in + let dt = Type.option a in + let pp = Type.pp dt in + ( dt, + fun ~old t1 t2 -> + [%log.debug "some %a | %a" pp t1 pp t2]; + f (default Type.(option a)) ~old t1 t2 >>= function + | Ok x -> ok x + | Error _ -> ( + match (t1, t2) with + | None, None -> ok None + | Some v1, Some v2 -> + let open Infix in + let old () = + old () >>=* function + | None -> ok None + | Some o -> + [%log.debug "option old=%a" pp o]; + ok o + in + t ~old v1 v2 >|=* fun x -> Some x + | Some x, None | None, Some x -> ( + let open Infix in + old () >>=* function + | None | Some None -> ok (Some x) + | Some (Some o) -> + [%log.debug "option old=%a" pp_a o]; + if equal x o then ok (Some x) else conflict "option: add/del") + ) ) + +let pair (da, a) (db, b) = + let dt = Type.pair da db in + let pp = Type.pp dt in + ( dt, + fun ~old x y -> + [%log.debug "pair %a | %a" pp x pp y]; + (snd (default dt)) ~old x y >>= function + | Ok x -> ok x + | Error _ -> + let (a1, b1), (a2, b2) = (x, y) in + let o1 = map_promise fst old in + let o2 = map_promise snd old in + a ~old:o1 a1 a2 >>=* fun a3 -> + b ~old:o2 b1 b2 >|=* fun b3 -> (a3, b3) ) + +let triple (da, a) (db, b) (dc, c) = + let dt = Type.triple da db dc in + let pp = Type.pp dt in + ( dt, + fun ~old x y -> + [%log.debug "triple %a | %a" pp x pp y]; + (snd (default dt)) ~old x y >>= function + | Ok x -> ok x + | Error _ -> + let (a1, b1, c1), (a2, b2, c2) = (x, y) in + let o1 = map_promise (fun (x, _, _) -> x) old in + let o2 = map_promise (fun (_, x, _) -> x) old in + let o3 = map_promise (fun (_, _, x) -> x) old in + a ~old:o1 a1 a2 >>=* fun a3 -> + b ~old:o2 b1 b2 >>=* fun b3 -> + c ~old:o3 c1 c2 >|=* fun c3 -> (a3, b3, c3) ) + +exception C of string + +let merge_elt merge_v old key vs = + let v1, v2 = + match vs with + | `Left v -> (Some v, None) + | `Right v -> (None, Some v) + | `Both (v1, v2) -> (Some v1, Some v2) + in + let old () = old key in + merge_v key ~old v1 v2 >>= function + | Error (`Conflict msg) -> Lwt.fail (C msg) + | Ok x -> Lwt.return x + +(* assume l1 and l2 are key-sorted *) +let alist_iter2 compare_k f l1 l2 = + let rec aux l1 l2 = + match (l1, l2) with + | [], t -> List.iter (fun (key, v) -> f key (`Right v)) t + | t, [] -> List.iter (fun (key, v) -> f key (`Left v)) t + | (k1, v1) :: t1, (k2, v2) :: t2 -> ( + match compare_k k1 k2 with + | 0 -> + f k1 (`Both (v1, v2)); + aux t1 t2 + | x -> + if x < 0 then ( + f k1 (`Left v1); + aux t1 l2) + else ( + f k2 (`Right v2); + aux l1 t2)) + in + aux l1 l2 + +(* assume l1 and l2 are key-sorted *) +let alist_iter2_lwt compare_k f l1 l2 = + let l3 = ref [] in + alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; + Lwt_list.iter_p Fun.id (List.rev !l3) + +(* DO NOT assume l1 and l2 are key-sorted *) +let alist_merge_lwt compare_k f l1 l2 = + let open Lwt in + let l3 = ref [] in + let sort l = List.sort (fun (x, _) (y, _) -> compare_k x y) l in + let l1 = sort l1 in + let l2 = sort l2 in + let f key data = + f key data >>= function + | None -> return_unit + | Some v -> + l3 := (key, v) :: !l3; + return_unit + in + alist_iter2_lwt compare_k f l1 l2 >>= fun () -> return !l3 + +let alist dx dy merge_v = + let pair = Type.pair dx dy in + let compare_pair = Type.unstage (Type.compare pair) in + let compare_dx = Type.(unstage (compare dx)) in + let dt = Type.list pair in + ( dt, + fun ~old x y -> + let pp = Type.pp dt in + [%log.debug "alist %a | %a" pp x pp y]; + let sort = List.sort compare_pair in + let x = sort x in + let y = sort y in + let old k = + let open Infix in + old () >|=* function + | None -> Some None (* no parent = parent with empty value *) + | Some old -> + let old = try Some (List.assoc k old) with Not_found -> None in + Some old + in + let merge_v k = f (merge_v k) in + Lwt.catch + (fun () -> + alist_merge_lwt compare_dx (merge_elt merge_v old) x y >>= ok) + (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) + +module MultiSet (K : sig + include Set.OrderedType + + val t : t Type.t +end) = +struct + module M = Map.Make (K) + + let of_alist l = List.fold_left (fun map (k, v) -> M.add k v map) M.empty l + let t = Type.map Type.(list (pair K.t int64)) of_alist M.bindings + + let merge ~old m1 m2 = + let get k m = try M.find k m with Not_found -> 0L in + let set k v m = match v with 0L -> M.remove k m | _ -> M.add k v m in + let add k v m = set k (Int64.add v @@ get k m) m in + let keys = ref M.empty in + old () >|=* fun old -> + let old = + match old with + | None -> M.empty (* no parent = parent with empty value *) + | Some o -> o + in + M.iter (fun k v -> keys := add k (Int64.neg v) !keys) old; + M.iter (fun k v -> keys := add k v !keys) m1; + M.iter (fun k v -> keys := add k v !keys) m2; + !keys + + let merge = (t, merge) +end + +module Set (K : sig + include Set.OrderedType + + val t : t Type.t +end) = +struct + module S = Set.Make (K) + + let of_list l = List.fold_left (fun set elt -> S.add elt set) S.empty l + let t = Type.(map @@ list K.t) of_list S.elements + let pp = Type.pp t + + let merge ~old x y = + [%log.debug "merge %a %a" pp x pp y]; + old () >|=* fun old -> + let old = match old with None -> S.empty | Some o -> o in + let ( ++ ) = S.union and ( -- ) = S.diff in + let to_add = x -- old ++ (y -- old) in + let to_del = old -- x ++ (old -- y) in + old -- to_del ++ to_add + + let merge = (t, merge) +end + +module Map (K : sig + include Map.OrderedType + + val t : t Type.t +end) = +struct + module M = Map.Make (K) + + let of_alist l = List.fold_left (fun map (k, v) -> M.add k v map) M.empty l + let t x = Type.map Type.(list @@ pair K.t x) of_alist M.bindings + let iter2 f t1 t2 = alist_iter2 K.compare f (M.bindings t1) (M.bindings t2) + + let iter2 f m1 m2 = + let m3 = ref [] in + iter2 (fun key data -> m3 := f key data :: !m3) m1 m2; + Lwt_list.iter_p (fun b -> b >>= fun () -> Lwt.return_unit) (List.rev !m3) + + let merge_maps f m1 m2 = + let l3 = ref [] in + let f key data = + f key data >|= function None -> () | Some v -> l3 := (key, v) :: !l3 + in + iter2 f m1 m2 >>= fun () -> + let m3 = of_alist !l3 in + Lwt.return m3 + + let merge dv (merge_v : K.t -> 'a option t) = + let pp ppf m = Type.(pp (list (pair K.t dv))) ppf @@ M.bindings m in + let merge_v k = f (merge_v k) in + ( t dv, + fun ~old m1 m2 -> + [%log.debug "assoc %a | %a" pp m1 pp m2]; + Lwt.catch + (fun () -> + let old key = + old () >>=* function + | None -> ok None + | Some old -> + [%log.debug "assoc old=%a" pp old]; + let old = + try Some (M.find key old) with Not_found -> None + in + ok (Some old) + in + merge_maps (merge_elt merge_v old) m1 m2 >>= ok) + (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) +end + +let like da t a_to_b b_to_a = + let pp = Type.pp da in + let merge ~old a1 a2 = + [%log.debug "biject %a | %a" pp a1 pp a2]; + try + let b1 = a_to_b a1 in + let b2 = a_to_b a2 in + let old = memo (map_promise a_to_b old) in + (f t) ~old b1 b2 >|=* b_to_a + with Not_found -> conflict "biject" + in + seq [ default da; (da, merge) ] + +let like_lwt (type a b) da (t : b t) (a_to_b : a -> b Lwt.t) + (b_to_a : b -> a Lwt.t) : a t = + let pp = Type.pp da in + let merge ~old a1 a2 = + [%log.debug "biject' %a | %a" pp a1 pp a2]; + try + let* b1 = a_to_b a1 in + let* b2 = a_to_b a2 in + let old = + memo (fun () -> + bind (old ()) @@ function + | None -> ok None + | Some a -> + let+ b = a_to_b a in + Ok (Some b)) + in + bind ((f t) ~old b1 b2) @@ fun b3 -> b_to_a b3 >>= ok + with Not_found -> conflict "biject'" + in + seq [ default da; (da, merge) ] + +let unit = default Type.unit +let bool = default Type.bool +let char = default Type.char +let int32 = default Type.int32 +let int64 = default Type.int64 +let float = default Type.float +let string = default Type.string + +type counter = int64 + +let counter = + ( Type.int64, + fun ~old x y -> + old () >|=* fun old -> + let old = match old with None -> 0L | Some o -> o in + let ( + ) = Int64.add and ( - ) = Int64.sub in + x + y - old ) + +let with_conflict rewrite (d, f) = + let f ~old x y = + f ~old x y >>= function + | Error (`Conflict msg) -> conflict "%s" (rewrite msg) + | Ok x -> ok x + in + (d, f) + +let conflict_t = + Type.(map string) (fun x -> `Conflict x) (function `Conflict x -> x) + +type nonrec 'a result = ('a, conflict) result [@@deriving irmin] diff --git a/vendors/irmin/src/irmin/merge.mli b/vendors/irmin/src/irmin/merge.mli new file mode 100644 index 0000000000000000000000000000000000000000..2ec7b19f34f696ce19da21b522abdb943eb8b040 --- /dev/null +++ b/vendors/irmin/src/irmin/merge.mli @@ -0,0 +1,227 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Merge operators. *) + +type conflict = [ `Conflict of string ] [@@deriving irmin] +(** The type for merge errors. *) + +val ok : 'a -> ('a, conflict) result Lwt.t +(** Return [Ok x]. *) + +val conflict : ('a, unit, string, ('b, conflict) result Lwt.t) format4 -> 'a +(** Return [Error (Conflict str)]. *) + +val bind : + ('a, 'b) result Lwt.t -> + ('a -> ('c, 'b) result Lwt.t) -> + ('c, 'b) result Lwt.t +(** [bind r f] is the merge result which behaves as of the application of the + function [f] to the return value of [r]. If [r] fails, [bind r f] also + fails, with the same conflict. *) + +val map : ('a -> 'c) -> ('a, 'b) result Lwt.t -> ('c, 'b) result Lwt.t +(** [map f m] maps the result of a merge. This is the same as + [bind m (fun x -> ok (f x))]. *) + +(** {1 Merge Combinators} *) + +type 'a promise = unit -> ('a option, conflict) result Lwt.t +(** An ['a] promise is a function which, when called, will eventually return a + value type of ['a]. A promise is an optional, lazy and non-blocking value. *) + +val promise : 'a -> 'a promise +(** [promise a] is the promise containing [a]. *) + +val map_promise : ('a -> 'b) -> 'a promise -> 'b promise +(** [map_promise f a] is the promise containing [f] applied to what is promised + by [a]. *) + +val bind_promise : 'a promise -> ('a -> 'b promise) -> 'b promise +(** [bind_promise a f] is the promise returned by [f] applied to what is + promised by [a]. *) + +type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t +(** Signature of a merge function. [old] is the value of the least-common + ancestor. + + {v + /----> t1 ----\ + ----> old |--> result + \----> t2 ----/ + v} *) + +type 'a t +(** The type for merge combinators. *) + +val v : 'a Type.t -> 'a f -> 'a t +(** [v dt f] create a merge combinator. *) + +val f : 'a t -> 'a f +(** [f m] is [m]'s merge function. *) + +val seq : 'a t list -> 'a t +(** Call the merge functions in sequence. Stop as soon as one is {e not} + returning a conflict. *) + +val like : 'a Type.t -> 'b t -> ('a -> 'b) -> ('b -> 'a) -> 'a t +(** Use the merge function defined in another domain. If the converting + functions raise any exception the merge is a conflict. *) + +val with_conflict : (string -> string) -> 'a t -> 'a t +(** [with_conflict f m] is [m] with the conflict error message modified by [f]. *) + +val like_lwt : 'a Type.t -> 'b t -> ('a -> 'b Lwt.t) -> ('b -> 'a Lwt.t) -> 'a t +(** Same as {{!Merge.biject} biject} but with blocking domain converting + functions. *) + +(** {1 Basic Merges} *) + +val default : 'a Type.t -> 'a t +(** [default t] is the default merge function for values of type [t]. This is a + simple merge function which supports changes in one branch at a time: + + - if [t1=old] then the result of the merge is [OK t2]; + - if [t2=old] then return [OK t1]; + - otherwise the result is [Conflict]. *) + +val idempotent : 'a Type.t -> 'a t +(** [idempotent t] is the default merge function for values of type [t] using + idempotent operations. It follows the same rules as the {!default} merge + function but also adds: + + - if [t1=t2] then the result of the merge is [OK t1]. *) + +val unit : unit t +(** [unit] is the default merge function for unit values. *) + +val bool : bool t +(** [bool] is the default merge function for booleans. *) + +val char : char t +(** [char] is the default merge function for characters. *) + +val int32 : int32 t +(** [int32] is the default merge function for 32-bits integers. *) + +val int64 : int64 t +(** [int64] the default merge function for 64-bit integers. *) + +val float : float t +(** [float] is the default merge function for floating point numbers. *) + +val string : string t +(** The default string merge function. Do not do anything clever, just compare + the strings using the [default] merge function. *) + +val option : 'a t -> 'a option t +(** Lift a merge function to optional values of the same type. If all the + provided values are inhabited, then call the provided merge function, + otherwise use the same behavior as {!default}. *) + +val pair : 'a t -> 'b t -> ('a * 'b) t +(** Lift merge functions to pairs of elements. *) + +val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t +(** Lift merge functions to triples of elements. *) + +(** {1 Counters and Multisets} *) + +type counter = int64 +(** The type for counter values. It is expected that the only valid operations + on counters are {e increment} and {e decrement}. The following merge + functions ensure that the counter semantics are preserved: {e i.e.} it + ensures that the number of increments and decrements is preserved. *) + +val counter : counter t +(** The merge function for mergeable counters. *) + +(** Multi-sets. *) +module MultiSet (K : sig + include Set.OrderedType + + val t : t Type.t +end) : sig + val merge : counter Map.Make(K).t t +end + +(** {1 Maps and Association Lists} *) + +(** We consider the only valid operations for maps and association lists to be: + + - Adding a new bindings to the map. + - Removing a binding from the map. + - Replacing an existing binding with a different value. + - {e Trying to add an already existing binding is a no-op}. + + We thus assume that no operation on maps is modifying the {e key} names. So + the following merge functions ensures that {e (i)} new bindings are + preserved {e (ii)} removed bindings stay removed and {e (iii)} modified + bindings are merged using the merge function of values. + + {b Note:} We only consider sets of bindings, instead of multisets. + Application developers should take care of concurrent addition and removal + of similar bindings themselves, by using the appropriate {{!Merge.MSet} + multi-sets}. *) + +(** Lift merge functions to sets. *) +module Set (E : sig + include Set.OrderedType + + val t : t Type.t +end) : sig + val merge : Set.Make(E).t t +end + +val alist : 'a Type.t -> 'b Type.t -> ('a -> 'b option t) -> ('a * 'b) list t +(** Lift the merge functions to association lists. *) + +(** Lift the merge functions to maps. *) + +module Map (K : sig + include Map.OrderedType + + val t : t Type.t +end) : sig + val merge : 'a Type.t -> (K.t -> 'a option t) -> 'a Map.Make(K).t t +end + +(** Infix operators for manipulating merge results and {!promise}s. + + [open Irmin.Merge.Infix] at the top of your file to use them. *) +module Infix : sig + (** {1 Merge Result Combinators} *) + + val ( >>=* ) : + ('a, conflict) result Lwt.t -> + ('a -> ('b, conflict) result Lwt.t) -> + ('b, conflict) result Lwt.t + (** [>>=*] is {!bind}. *) + + val ( >|=* ) : + ('a, conflict) result Lwt.t -> ('a -> 'b) -> ('b, conflict) result Lwt.t + (** [>|=*] is {!map}. *) + + (** {1 Promise Combinators} + + This is useful to manipulate lca results. *) + + val ( >>=? ) : 'a promise -> ('a -> 'b promise) -> 'b promise + (** [>>=?] is {!bind_promise}. *) + + val ( >|=? ) : 'a promise -> ('a -> 'b) -> 'b promise + (** [>|=?] is {!map_promise}. *) +end diff --git a/vendors/irmin/src/irmin/metadata.ml b/vendors/irmin/src/irmin/metadata.ml new file mode 100644 index 0000000000000000000000000000000000000000..a0a8c2505523a5a9774992591d734cbfe89dd520 --- /dev/null +++ b/vendors/irmin/src/irmin/metadata.ml @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Metadata_intf + +module None = struct + type t = unit [@@deriving irmin] + + let default = () + let merge = Merge.v t (fun ~old:_ () () -> Merge.ok ()) +end diff --git a/vendors/irmin/src/irmin/metadata.mli b/vendors/irmin/src/irmin/metadata.mli new file mode 100644 index 0000000000000000000000000000000000000000..c8808836a3548915bd83b8576f9e859bc2a4c21f --- /dev/null +++ b/vendors/irmin/src/irmin/metadata.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Metadata_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/metadata_intf.ml b/vendors/irmin/src/irmin/metadata_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..3ecacde227fec443f4b6663d2d32172d79700477 --- /dev/null +++ b/vendors/irmin/src/irmin/metadata_intf.ml @@ -0,0 +1,31 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Node metadata. *) + +module type S = sig + include Type.Defaultable + + val merge : t Merge.t + (** [merge] is the merge function for metadata. *) +end + +module type Sigs = sig + module type S = S + + module None : S with type t = unit + (** A metadata definition for systems that don't use metadata. *) +end diff --git a/vendors/irmin/src/irmin/metrics.ml b/vendors/irmin/src/irmin/metrics.ml new file mode 100644 index 0000000000000000000000000000000000000000..eb3422c4c171df034b510c128e2584b4e5e2e992 --- /dev/null +++ b/vendors/irmin/src/irmin/metrics.ml @@ -0,0 +1,46 @@ +(* +* Copyright (c) 2022 - Étienne Marais +* +* Permission to use, copy, modify, and distribute this software for any +* purpose with or without fee is hereby granted, provided that the above +* copyright notice and this permission notice appear in all copies. +* +* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +*) + +let uid = + let id = ref (-1) in + fun () -> + incr id; + !id + +type origin = .. + +type 'a t = { + uid : int; + name : string; + origin : origin option; + repr : 'a Repr.ty; + mutable state : 'a; +} + +let state m = m.state +let set_state m v = m.state <- v + +type 'a update_mode = Mutate of ('a -> unit) | Replace of ('a -> 'a) + +let v : + type a. ?origin:origin -> name:string -> initial_state:a -> a Repr.ty -> a t + = + fun ?origin ~name ~initial_state repr -> + { uid = uid (); origin; name; repr; state = initial_state } + +let update : type a. a t -> a update_mode -> unit = + fun m kind -> + match kind with Mutate f -> f m.state | Replace f -> m.state <- f m.state diff --git a/vendors/irmin/src/irmin/metrics.mli b/vendors/irmin/src/irmin/metrics.mli new file mode 100644 index 0000000000000000000000000000000000000000..a8f4caf6c997b4f9bac09c6bac9f078f09e4961d --- /dev/null +++ b/vendors/irmin/src/irmin/metrics.mli @@ -0,0 +1,54 @@ +(* + * Copyright (c) 2022 Etienne Marais + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [Metrics] defines primitives to handle metrics inside of Irmin. Its purpose + is to decouple the metrics type definition from the data manipulation. + + A {!t} can be modified in different ways, depending on the {!update_mode}. *) + +type origin = .. +(** An extensible type to get the location of the definition. *) + +type 'a t +(** {!t} is the object that describes how a {!t} is gathered and store. The ['a] + parameter represents the type of the internal data. *) + +val state : 'a t -> 'a +(** The internal state extracted from a {!t}. *) + +val set_state : 'a t -> 'a -> unit +(** [set_state m v] updates the value in the {!t} object. *) + +(** {!update_mode} describes how the data will be handled by the {!update} + function. + + - Mutate: the value and the storage are not modified but the content of the + value can be mutate. + - Replace f: apply f to the value and updates its content. + + It gives the possibility to handle the same metric in different ways. *) +type 'a update_mode = Mutate of ('a -> unit) | Replace of ('a -> 'a) + +val v : ?origin:origin -> name:string -> initial_state:'a -> 'a Repr.ty -> 'a t +(** [v ~origin ~name ~initial_state repr ] create a new {!t}. The [origin] can + be set to give an hint about where the data are gathered. [name] is a name + to describe this metrics. [initial_state] is the first value to store in the + metric object. [repr] describes the type representation to allow + serialization. *) + +val update : 'a t -> 'a update_mode -> unit +(** [update metrics mode] updates the metric by taking in consideration [mode] + to define how it acts on [t] according to their specication. *) diff --git a/vendors/irmin/src/irmin/node.ml b/vendors/irmin/src/irmin/node.ml new file mode 100644 index 0000000000000000000000000000000000000000..72d3f008be8a4283d77e7c46dff7e4972a8256ca --- /dev/null +++ b/vendors/irmin/src/irmin/node.ml @@ -0,0 +1,785 @@ +(* + * Copyright (c) 2013 Louis Gesbert + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Node_intf + +let src = Logs.Src.create "irmin.node" ~doc:"Irmin trees/nodes" + +module Log = (val Logs.src_log src : Logs.LOG) + +(* Add [merge] to a [Core] implementation. *) +module Of_core (S : Core) = struct + include S + (* Merges *) + + let all_contents t = + let kvs = S.list t in + List.fold_left + (fun acc -> function k, `Contents c -> (k, c) :: acc | _ -> acc) + [] kvs + + let all_succ t = + let kvs = S.list t in + List.fold_left + (fun acc -> function k, `Node n -> (k, n) :: acc | _ -> acc) + [] kvs + + (* [Merge.alist] expects us to return an option. [C.merge] does + that, but we need to consider the metadata too... *) + let merge_metadata merge_contents = + (* This gets us [C.t option, S.Val.Metadata.t]. We want [(C.t * + S.Val.Metadata.t) option]. *) + let explode = function + | None -> (None, S.Metadata.default) + | Some (c, m) -> (Some c, m) + in + let implode = function None, _ -> None | Some c, m -> Some (c, m) in + Merge.like [%typ: (S.contents_key * S.metadata) option] + (Merge.pair merge_contents S.Metadata.merge) + explode implode + + let merge_contents merge_key = + Merge.alist S.step_t (Type.pair S.contents_key_t S.metadata_t) (fun _step -> + merge_metadata merge_key) + + let merge_node merge_key = + Merge.alist S.step_t S.node_key_t (fun _step -> merge_key) + + (* FIXME: this is very broken; do the same thing as [Tree.merge] + instead. *) + let merge ~contents ~node = + let explode t = (all_contents t, all_succ t) in + let implode (contents, succ) = + let xs = List.rev_map (fun (s, c) -> (s, `Contents c)) contents in + let ys = List.rev_map (fun (s, n) -> (s, `Node n)) succ in + S.of_list (xs @ ys) + in + let merge = Merge.pair (merge_contents contents) (merge_node node) in + Merge.like S.t merge explode implode +end + +module Irmin_hash = Hash + +(* A [Make] implementation providing the subset of [S] that can be implemented + over abstract [key] types. *) +module Make_core + (Hash : Hash.S) (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) + (Contents_key : Key.S with type hash = Hash.t) + (Node_key : Key.S with type hash = Hash.t) = +struct + module Metadata = Metadata + + type contents_key = Contents_key.t [@@deriving irmin] + type node_key = Node_key.t [@@deriving irmin] + type step = Path.step [@@deriving irmin] + type metadata = Metadata.t [@@deriving irmin ~equal] + type hash = Hash.t [@@deriving irmin] + + type 'key contents_entry = { name : Path.step; contents : 'key } + [@@deriving irmin] + + type 'key contents_m_entry = { + metadata : Metadata.t; + name : Path.step; + contents : 'key; + } + [@@deriving irmin] + + module StepMap = Map.Make (struct + type t = Path.step [@@deriving irmin ~compare] + end) + + type 'h node_entry = { name : Path.step; node : 'h } [@@deriving irmin] + + type entry = + | Node of node_key node_entry + | Contents of contents_key contents_entry + | Contents_m of contents_key contents_m_entry + (* Invariant: the [_hash] cases are only externally reachable via + [Portable.of_node]. *) + | Node_hash of Hash.t node_entry + | Contents_hash of Hash.t contents_entry + | Contents_m_hash of Hash.t contents_m_entry + [@@deriving irmin] + + type t = entry StepMap.t + type value = [ `Contents of contents_key * metadata | `Node of node_key ] + + type weak_value = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + + (* FIXME: special-case the default metadata in the default signature? *) + let value_t = + let open Type in + variant "value" (fun n c x -> function + | `Node h -> n h + | `Contents (h, m) -> + if equal_metadata m Metadata.default then c h else x (h, m)) + |~ case1 "node" node_key_t (fun k -> `Node k) + |~ case1 "contents" contents_key_t (fun h -> + `Contents (h, Metadata.default)) + |~ case1 "contents-x" (pair contents_key_t Metadata.t) (fun (h, m) -> + `Contents (h, m)) + |> sealv + + let to_entry (k, (v : value)) = + match v with + | `Node h -> Node { name = k; node = h } + | `Contents (h, m) -> + if equal_metadata m Metadata.default then + Contents { name = k; contents = h } + else Contents_m { metadata = m; name = k; contents = h } + + let inspect_nonportable_entry_exn : entry -> step * value = function + | Node n -> (n.name, `Node n.node) + | Contents c -> (c.name, `Contents (c.contents, Metadata.default)) + | Contents_m c -> (c.name, `Contents (c.contents, c.metadata)) + | Node_hash _ | Contents_hash _ | Contents_m_hash _ -> + (* Not reachable after [Portable.of_node]. See invariant on {!entry}. *) + assert false + + let step_of_entry : entry -> step = function + | Node { name; _ } + | Node_hash { name; _ } + | Contents { name; _ } + | Contents_m { name; _ } + | Contents_hash { name; _ } + | Contents_m_hash { name; _ } -> + name + + let weak_of_entry : entry -> step * weak_value = function + | Node n -> (n.name, `Node (Node_key.to_hash n.node)) + | Node_hash n -> (n.name, `Node n.node) + | Contents c -> + (c.name, `Contents (Contents_key.to_hash c.contents, Metadata.default)) + | Contents_m c -> + (c.name, `Contents (Contents_key.to_hash c.contents, c.metadata)) + | Contents_hash c -> (c.name, `Contents (c.contents, Metadata.default)) + | Contents_m_hash c -> (c.name, `Contents (c.contents, c.metadata)) + + let of_seq l = + Seq.fold_left + (fun acc x -> StepMap.add (fst x) (to_entry x) acc) + StepMap.empty l + + let of_list l = of_seq (List.to_seq l) + + let seq_entries ~offset ?length (t : t) = + let take seq = match length with None -> seq | Some n -> Seq.take n seq in + StepMap.to_seq t |> Seq.drop offset |> take + + let seq ?(offset = 0) ?length ?cache:_ (t : t) = + seq_entries ~offset ?length t + |> Seq.map (fun (_, e) -> inspect_nonportable_entry_exn e) + + let list ?offset ?length ?cache:_ t = List.of_seq (seq ?offset ?length t) + let find_entry ?cache:_ (t : t) s = StepMap.find_opt s t + + let find ?cache (t : t) s = + Option.map + (fun e -> snd (inspect_nonportable_entry_exn e)) + (find_entry ?cache t s) + + let empty = Fun.const StepMap.empty + let is_empty e = StepMap.is_empty e + let length e = StepMap.cardinal e + let clear _ = () + let equal_entry_opt = Type.(unstage (equal (option entry_t))) + + let add_entry t k e = + StepMap.update k + (fun e' -> if equal_entry_opt (Some e) e' then e' else Some e) + t + + let add t k v = + let e = to_entry (k, v) in + add_entry t k e + + let remove t k = StepMap.remove k t + + let of_entries es = + List.to_seq es |> Seq.map (fun e -> (step_of_entry e, e)) |> StepMap.of_seq + + let entries e = List.rev_map (fun (_, e) -> e) (StepMap.bindings e) + + module Hash_preimage = struct + type entry = + | Node_hash of Hash.t node_entry + | Contents_hash of Hash.t contents_entry + | Contents_m_hash of Hash.t contents_m_entry + [@@deriving irmin] + + type t = entry list [@@deriving irmin ~pre_hash] + type t_not_prefixed = t [@@deriving irmin ~pre_hash] + + let pre_hash = Type.(unstage (pre_hash t)) + + (* Manually add a prefix to default nodes, in order to prevent hash + collision between contents and nodes (see + https://github.com/mirage/irmin/issues/1304). + + Prefixing the contents is not enough to prevent the collision: the + prehash of a node starts with the number of its children, which can + coincide with the prefix of the content's prehash. *) + let pre_hash x f = + f "N"; + pre_hash x f + end + + let pre_hash pre_hash t f = + let entries : Hash_preimage.t = + StepMap.to_seq t + |> Seq.map (fun (_, v) -> + match v with + (* Weaken keys to hashes *) + | Node { name; node } -> + Hash_preimage.Node_hash { name; node = Node_key.to_hash node } + | Contents { name; contents } -> + Contents_hash + { name; contents = Contents_key.to_hash contents } + | Contents_m { metadata; name; contents } -> + Contents_m_hash + { metadata; name; contents = Contents_key.to_hash contents } + | Node_hash { name; node } -> Node_hash { name; node } + | Contents_hash { name; contents } -> + Contents_hash { name; contents } + | Contents_m_hash { metadata; name; contents } -> + Contents_m_hash { metadata; name; contents }) + |> Seq.fold_left (fun xs x -> x :: xs) [] + in + pre_hash entries f + + let t = + let pre_hash = pre_hash Hash_preimage.pre_hash in + Type.map ~pre_hash Type.(list entry_t) of_entries entries + + let t_not_prefixed = + let pre_hash = pre_hash Hash_preimage.pre_hash_t_not_prefixed in + Type.map ~pre_hash Type.(list entry_t) of_entries entries + + let with_handler _ t = t + + let head_entries t = + let l = seq_entries ~offset:0 t |> List.of_seq in + `Node l + + let head t = + let (`Node l) = head_entries t in + let l = List.map (fun (_, e) -> inspect_nonportable_entry_exn e) l in + `Node l + + module Ht = + Irmin_hash.Typed + (Hash) + (struct + type nonrec t = t [@@deriving irmin] + end) + + let hash_exn ?force:_ = Ht.hash +end + +module Portable = struct + module Of_core (X : sig + type hash + + include + Core + with type hash := hash + and type contents_key = hash + and type node_key = hash + end) = + struct + include X + + let of_node t = t + + type proof = + [ `Blinded of hash + | `Values of (step * value) list + | `Inode of int * (int * proof) list ] + [@@deriving irmin] + + let to_proof (t : t) : proof = `Values (seq t |> List.of_seq) + + let of_proof ~depth (t : proof) = + assert (depth = 0); + match t with + | `Blinded _ | `Inode _ -> None + | `Values e -> Some (of_list e) + end + + module Of_node (X : S) = struct + include Of_core (X) + include X + end + + module type S = Portable +end + +module Make_generic_key + (Hash : Hash.S) (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) + (Contents_key : Key.S with type hash = Hash.t) + (Node_key : Key.S with type hash = Hash.t) = +struct + module Core = Make_core (Hash) (Path) (Metadata) (Contents_key) (Node_key) + include Core + include Of_core (Core) + + module Portable = struct + module Core = struct + include Core + + type contents_key = hash [@@deriving irmin] + type node_key = hash [@@deriving irmin] + type value = weak_value [@@deriving irmin] + + let to_entry name = function + | `Node node -> Node_hash { name; node } + | `Contents (contents, metadata) -> + if equal_metadata metadata Metadata.default then + Contents_hash { name; contents } + else Contents_m_hash { name; contents; metadata } + + let of_seq s = + Seq.fold_left + (fun acc (name, v) -> StepMap.add name (to_entry name v) acc) + StepMap.empty s + + let of_list s = of_seq (List.to_seq s) + + let add t name v = + let entry = to_entry name v in + add_entry t name entry + + let find ?cache t s = + Option.map (fun e -> snd (weak_of_entry e)) (find_entry ?cache t s) + + let seq ?(offset = 0) ?length ?cache:_ (t : t) = + seq_entries ~offset ?length t |> Seq.map (fun (_, e) -> weak_of_entry e) + + let list ?offset ?length ?cache t = + List.of_seq (seq ?offset ?length ?cache t) + + let head t = + let (`Node l) = head_entries t in + let l = List.map (fun (_, e) -> weak_of_entry e) l in + `Node l + end + + include Of_core (Core) + include Portable.Of_core (Core) + end + + exception Dangling_hash of { context : string; hash : hash } + + type nonrec hash = hash [@@deriving irmin ~pp] + + let () = + Printexc.register_printer (function + | Dangling_hash { context; hash } -> + Some (Fmt.str "%s: encountered dangling hash %a" context pp_hash hash) + | _ -> None) +end + +module Make_generic_key_v2 + (Hash : Hash.S) (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) + (Contents_key : Key.S with type hash = Hash.t) + (Node_key : Key.S with type hash = Hash.t) = +struct + include Make_generic_key (Hash) (Path) (Metadata) (Contents_key) (Node_key) + + let t = t_not_prefixed + + module Portable = struct + include Portable + + let t = t_not_prefixed + end +end + +module Make + (Hash : Hash.S) (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) = +struct + module Key = Key.Of_hash (Hash) + include Make_generic_key (Hash) (Path) (Metadata) (Key) (Key) +end + +module Store_generic_key + (C : Contents.Store) + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (V : S_generic_key + with type t = S.value + and type contents_key = C.Key.t + and type node_key = S.Key.t) + (M : Metadata.S with type t = V.metadata) + (P : Path.S with type step = V.step) = +struct + module Val = struct + include V + + type hash = H.t + end + + module Contents = C + module Key = S.Key + module Hash = Hash.Typed (H) (Val) + module Path = P + module Metadata = M + + type 'a t = 'a C.t * 'a S.t + type value = S.value + type key = Key.t + type hash = Hash.t + + let mem (_, t) = S.mem t + let find (_, t) = S.find t + let add (_, t) = S.add t + let unsafe_add (_, t) = S.unsafe_add t + let index (_, t) h = S.index t h + let batch (c, s) f = C.batch c (fun n -> S.batch s (fun s -> f (n, s))) + + let close (c, s) = + let* () = C.close c in + let+ () = S.close s in + () + + let rec merge t = + let merge_key = + Merge.v [%typ: Key.t option] (fun ~old x y -> + Merge.(f (merge t)) ~old x y) + in + let merge = Val.merge ~contents:C.(merge (fst t)) ~node:merge_key in + let read = function + | None -> Lwt.return (Val.empty ()) + | Some k -> ( find t k >|= function None -> Val.empty () | Some v -> v) + in + let add v = + if Val.is_empty v then Lwt.return_none else add t v >>= Lwt.return_some + in + Merge.like_lwt [%typ: Key.t option] merge read add +end + +module Generic_key = struct + module type S = S_generic_key + module type Maker = Maker_generic_key + module type Core = Core + + module Make = Make_generic_key + module Store = Store_generic_key + module Make_v2 = Make_generic_key_v2 +end + +module Store + (C : Contents.Store) + (S : Content_addressable.S with type key = C.key) + (H : Hash.S with type t = S.key) + (V : S with type t = S.value and type hash = S.key) + (M : Metadata.S with type t = V.metadata) + (P : Path.S with type step = V.step) = +struct + module S = Indexable.Of_content_addressable (H) (S) + include Store_generic_key (C) (S) (H) (V) (M) (P) +end + +module Graph (S : Store) = struct + module Path = S.Path + module Contents_key = S.Contents.Key + module Metadata = S.Metadata + + type step = Path.step [@@deriving irmin] + type metadata = Metadata.t [@@deriving irmin] + type contents_key = Contents_key.t [@@deriving irmin] + type node_key = S.Key.t [@@deriving irmin] + type path = Path.t [@@deriving irmin] + type 'a t = 'a S.t + type value = [ `Contents of contents_key * metadata | `Node of node_key ] + + let empty t = S.add t (S.Val.empty ()) + + let list t n = + [%log.debug "steps"]; + S.find t n >|= function None -> [] | Some n -> S.Val.list n + + module U = struct + type t = unit [@@deriving irmin] + end + + module Graph = Object_graph.Make (Contents_key) (S.Key) (U) (U) + + let edges t = + List.rev_map + (function _, `Node n -> `Node n | _, `Contents (c, _) -> `Contents c) + (S.Val.list t) + + let pp_key = Type.pp S.Key.t + let pp_keys = Fmt.(Dump.list pp_key) + let pp_path = Type.pp S.Path.t + let equal_val = Type.(unstage (equal S.Val.t)) + + let pred t = function + | `Node k -> ( S.find t k >|= function None -> [] | Some v -> edges v) + | _ -> Lwt.return_nil + + let closure t ~min ~max = + [%log.debug "closure min=%a max=%a" pp_keys min pp_keys max]; + let min = List.rev_map (fun x -> `Node x) min in + let max = List.rev_map (fun x -> `Node x) max in + let+ g = Graph.closure ~pred:(pred t) ~min ~max () in + List.fold_left + (fun acc -> function `Node x -> x :: acc | _ -> acc) + [] (Graph.vertex g) + + let ignore_lwt _ = Lwt.return_unit + + let iter t ~min ~max ?(node = ignore_lwt) ?(contents = ignore_lwt) ?edge + ?(skip_node = fun _ -> Lwt.return_false) + ?(skip_contents = fun _ -> Lwt.return_false) ?(rev = true) () = + let min = List.rev_map (fun x -> `Node x) min in + let max = List.rev_map (fun x -> `Node x) max in + let node = function + | `Node x -> node x + | `Contents c -> contents c + | `Branch _ | `Commit _ -> Lwt.return_unit + in + let edge = + Option.map + (fun edge n pred -> + match (n, pred) with + | `Node src, `Node dst -> edge src dst + | _ -> Lwt.return_unit) + edge + in + let skip = function + | `Node x -> skip_node x + | `Contents c -> skip_contents c + | _ -> Lwt.return_false + in + Graph.iter ~pred:(pred t) ~min ~max ~node ?edge ~skip ~rev () + + let v t xs = S.add t (S.Val.of_list xs) + + let find_step t node step = + [%log.debug "contents %a" pp_key node]; + S.find t node >|= function None -> None | Some n -> S.Val.find n step + + let find t node path = + [%log.debug "read_node_exn %a %a" pp_key node pp_path path]; + let rec aux node path = + match Path.decons path with + | None -> Lwt.return_some (`Node node) + | Some (h, tl) -> ( + find_step t node h >>= function + | (None | Some (`Contents _)) as x -> Lwt.return x + | Some (`Node node) -> aux node tl) + in + aux node path + + let err_empty_path () = invalid_arg "Irmin.node: empty path" + + let map_one t node f label = + [%log.debug "map_one %a" Type.(pp Path.step_t) label]; + let old_key = S.Val.find node label in + let* old_node = + match old_key with + | None | Some (`Contents _) -> Lwt.return (S.Val.empty ()) + | Some (`Node k) -> ( + S.find t k >|= function None -> S.Val.empty () | Some v -> v) + in + let* new_node = f old_node in + if equal_val old_node new_node then Lwt.return node + else if S.Val.is_empty new_node then + let node = S.Val.remove node label in + if S.Val.is_empty node then Lwt.return (S.Val.empty ()) + else Lwt.return node + else + let+ k = S.add t new_node in + S.Val.add node label (`Node k) + + let map t node path f = + [%log.debug "map %a %a" pp_key node pp_path path]; + let rec aux node path = + match Path.decons path with + | None -> Lwt.return (f node) + | Some (h, tl) -> map_one t node (fun node -> aux node tl) h + in + let* node = + S.find t node >|= function None -> S.Val.empty () | Some n -> n + in + aux node path >>= S.add t + + let add t node path n = + [%log.debug "add %a %a" pp_key node pp_path path]; + match Path.rdecons path with + | Some (path, file) -> map t node path (fun node -> S.Val.add node file n) + | None -> ( + match n with + | `Node n -> Lwt.return n + | `Contents _ -> failwith "TODO: Node.add") + + let rdecons_exn path = + match Path.rdecons path with + | Some (l, t) -> (l, t) + | None -> err_empty_path () + + let remove t node path = + let path, file = rdecons_exn path in + map t node path (fun node -> S.Val.remove node file) + + let value_t = S.Val.value_t +end + +module V1 (N : Generic_key.S with type step = string) = struct + module K (H : Type.S) = struct + let h = Type.string_of `Int64 + + type t = H.t [@@deriving irmin ~to_bin_string ~of_bin_string] + + let size_of = Type.Size.using to_bin_string (Type.Size.t h) + + let encode_bin = + let encode_bin = Type.(unstage (encode_bin h)) in + fun e k -> encode_bin (to_bin_string e) k + + let decode_bin = + let decode_bin = Type.(unstage (decode_bin h)) in + fun buf pos_ref -> + let v = decode_bin buf pos_ref in + match of_bin_string v with + | Ok v -> v + | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e + + let t = Type.like t ~bin:(encode_bin, decode_bin, size_of) + end + + module Node_key = K (struct + type t = N.node_key + + let t = N.node_key_t + end) + + module Contents_key = K (struct + type t = N.contents_key + + let t = N.contents_key_t + end) + + module Metadata = N.Metadata + + type step = N.step + type node_key = Node_key.t [@@deriving irmin] + type contents_key = Contents_key.t [@@deriving irmin] + type metadata = N.metadata [@@deriving irmin] + type hash = N.hash [@@deriving irmin] + type value = N.value + type t = { n : N.t; entries : (step * value) list } + + exception Dangling_hash = N.Dangling_hash + + let import n = { n; entries = N.list n } + let export t = t.n + let with_handler _ t = t + let hash_exn ?force t = N.hash_exn ?force t.n + let head t = N.head t.n + + let of_seq entries = + let n = N.of_seq entries in + let entries = List.of_seq entries in + { n; entries } + + let of_list entries = + let n = N.of_list entries in + { n; entries } + + let seq ?(offset = 0) ?length ?cache:_ t = + let take seq = match length with None -> seq | Some n -> Seq.take n seq in + List.to_seq t.entries |> Seq.drop offset |> take + + let list ?offset ?length ?cache t = List.of_seq (seq ?offset ?length ?cache t) + let empty () = { n = N.empty (); entries = [] } + let is_empty t = t.entries = [] + let length e = N.length e.n + let clear _ = () + let find ?cache t k = N.find ?cache t.n k + + let add t k v = + let n = N.add t.n k v in + if t.n == n then t else { n; entries = N.list n } + + let remove t k = + let n = N.remove t.n k in + if t.n == n then t else { n; entries = N.list n } + + let v1_step = Type.string_of `Int64 + let step_to_bin_string = Type.(unstage (to_bin_string v1_step)) + let step_of_bin_string = Type.(unstage (of_bin_string v1_step)) + + let step_t : step Type.t = + let to_string p = step_to_bin_string p in + let of_string s = + step_of_bin_string s |> function + | Ok x -> x + | Error (`Msg e) -> Fmt.failwith "Step.of_string: %s" e + in + Type.(map (string_of `Int64)) of_string to_string + + let is_default = Type.(unstage (equal N.metadata_t)) Metadata.default + + let value_t = + let open Type in + record "node" (fun contents metadata node -> + match (contents, metadata, node) with + | Some c, None, None -> `Contents (c, Metadata.default) + | Some c, Some m, None -> `Contents (c, m) + | None, None, Some n -> `Node n + | _ -> failwith "invalid node") + |+ field "contents" (option Contents_key.t) (function + | `Contents (x, _) -> Some x + | _ -> None) + |+ field "metadata" (option metadata_t) (function + | `Contents (_, x) when not (is_default x) -> Some x + | _ -> None) + |+ field "node" (option Node_key.t) (function + | `Node n -> Some n + | _ -> None) + |> sealr + + let t : t Type.t = + Type.map Type.(list ~len:`Int64 (pair step_t value_t)) of_list list + + let merge ~contents ~node = + let merge = N.merge ~contents ~node in + let f ~old x y = + let old = Merge.map_promise (fun old -> old.n) old in + let+ r = Merge.f merge ~old x.n y.n in + match r with Ok r -> Ok (import r) | Error e -> Error e + in + Merge.v t f +end diff --git a/vendors/irmin/src/irmin/node.mli b/vendors/irmin/src/irmin/node.mli new file mode 100644 index 0000000000000000000000000000000000000000..8cbe4350b16f86a1ec4bb3ba4659b1ef92f6771a --- /dev/null +++ b/vendors/irmin/src/irmin/node.mli @@ -0,0 +1,27 @@ +(* + * Copyright (c) 2013 Louis Gesbert + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [Node] provides functions to describe the graph-like structured values. + + The node blocks form a labeled directed acyclic graph, labeled by + {{!Path.S.step} steps}: a list of steps defines a unique path from one node + to an other. + + Each node can point to user-defined {{!Contents.S} contents} values. *) + +include Node_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/node_intf.ml b/vendors/irmin/src/irmin/node_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..27f03fdcb3575deb9909e0e0e806a5e87df5a906 --- /dev/null +++ b/vendors/irmin/src/irmin/node_intf.ml @@ -0,0 +1,476 @@ +(* + * Copyright (c) 2013 Louis Gesbert + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type Core = sig + (** {1 Node values} *) + + type t [@@deriving irmin] + (** The type for node values. *) + + type metadata [@@deriving irmin] + (** The type for node metadata. *) + + type contents_key [@@deriving irmin] + (** The type for contents keys. *) + + type node_key [@@deriving irmin] + (** The type for node keys. *) + + type step [@@deriving irmin] + (** The type for steps between nodes. *) + + type value = [ `Node of node_key | `Contents of contents_key * metadata ] + [@@deriving irmin] + (** The type for either (node) keys or (contents) keys combined with their + metadata. *) + + type hash [@@deriving irmin] + (** The type of hashes of values. *) + + val of_list : (step * value) list -> t + (** [of_list l] is the node [n] such that [list n = l]. *) + + val list : + ?offset:int -> ?length:int -> ?cache:bool -> t -> (step * value) list + (** [list t] is the contents of [t]. [offset] and [length] are used to + paginate results. *) + + val of_seq : (step * value) Seq.t -> t + (** [of_seq s] is the node [n] such that [seq n = s]. *) + + val seq : + ?offset:int -> ?length:int -> ?cache:bool -> t -> (step * value) Seq.t + (** [seq t] is the contents of [t]. [offset] and [length] are used to paginate + results. + + See {!caching} for an explanation of the [cache] parameter *) + + val empty : unit -> t + (** [empty ()] is the empty node. *) + + val is_empty : t -> bool + (** [is_empty t] is true iff [t] is {!empty}. *) + + val length : t -> int + (** [length t] is the number of entries in [t]. *) + + val hash_exn : ?force:bool -> t -> hash + (** [hash_exn t] is the hash of [t]. + + Another way of computing it is [Hash.Typed(Hash)(Node).hash t] which + computes the pre-hash of [t] before hashing it using [Hash]. [hash_exn] + might be faster because the it may be optimised (e.g. it may use caching). + + [hash_exn t] is [hash_exn ~force:true t] which is not expected to raise an + exception. [hash_exn ~force:false t] will raise [Not_found] if the hash + requires IOs to be computed. *) + + val clear : t -> unit + (** Cleanup internal caches. *) + + val find : ?cache:bool -> t -> step -> value option + (** [find t s] is the value associated with [s] in [t]. + + A node can point to user-defined {{!contents_key} contents}. The edge + between the node and the contents is labeled by a {!step}. + + See {!caching} for an explanation of the [cache] parameter *) + + val add : t -> step -> value -> t + (** [add t s v] is the node where [find t v] is [Some s] but is similar to [t] + otherwise. *) + + val remove : t -> step -> t + (** [remove t s] is the node where [find t s] is [None] but is similar to [t] + otherwise. *) + + module Metadata : Metadata.S with type t = metadata + (** Metadata functions. *) + + (** {2:caching caching} + + [cache] regulates the caching behaviour regarding the node's internal data + which may be lazily loaded from the backend, depending on the node + implementation. + + [cache] defaults to [true] which may greatly reduce the IOs and the + runtime but may also increase the memory consumption. + + [cache = false] doesn't replace a call to [clear], it only prevents the + storing of new data, it doesn't discard the existing one. *) + + (** {1 Recursive Nodes} *) + + (** Some [Node] implementations (like [irmin-pack]'s inodes) can represent a + node as a set of nodes. One operation on such "high-level" node + corresponds to a sequence of recursive calls to the underlying + "lower-level" nodes. Note: theses [effects] are not in the Lwt monad on + purpose (so [Tree.hash] and [Tree.equal] are not in the Lwt monad as + well). *) + + type effect := expected_depth:int -> node_key -> t option + (** The type for read effects. *) + + val with_handler : (effect -> effect) -> t -> t + (** [with_handler f] replace the current effect handler [h] by [f h]. [f h] + will be called for all the recursive read effects that are required by + recursive operations on nodes. .*) + + type head := + [ `Node of (step * value) list | `Inode of int * (int * hash) list ] + [@@deriving irmin] + + val head : t -> head + (** Reveal the shallow internal structure of the node. + + Only hashes and not keys are revealed in the [`Inode] case, this is + because these inodes might not be keyed yet. *) +end + +module type S_generic_key = sig + include Core + (** @inline *) + + (** {2 merging} *) + + val merge : + contents:contents_key option Merge.t -> + node:node_key option Merge.t -> + t Merge.t + (** [merge] is the merge function for nodes. *) + + exception Dangling_hash of { context : string; hash : hash } +end + +module type S = sig + type hash + + (** @inline *) + include + S_generic_key + with type hash := hash + and type contents_key = hash + and type node_key = hash +end + +module type Portable = sig + type hash + + (** @inline *) + include + Core + with type hash := hash + and type contents_key = hash + and type node_key = hash + + type node + + val of_node : node -> t + + (** {2 merging} *) + + val merge : + contents:contents_key option Merge.t -> + node:node_key option Merge.t -> + t Merge.t + (** [merge] is the merge function for nodes. *) + + (** {1 Proofs} *) + + type proof = + [ `Blinded of hash + | `Values of (step * value) list + | `Inode of int * (int * proof) list ] + [@@deriving irmin] + (** The type for proof trees. *) + + val to_proof : t -> proof + + val of_proof : depth:int -> proof -> t option + (** [of_proof ~depth p] is [None] if [p] is corrupted or incompatible with + [depth]. It is [Some t] when [t] is a node if the operation succeeded. + + [hash_exn t] never raises [Not_found] *) +end + +open struct + module S_is_a_generic_key (X : S) : S_generic_key = X +end + +module type Maker_generic_key = functor + (Hash : Hash.S) + (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) + (Contents_key : Key.S with type hash = Hash.t) + (Node_key : Key.S with type hash = Hash.t) + -> sig + include + S_generic_key + with type metadata = Metadata.t + and type step = Path.step + and type hash = Hash.t + and type contents_key = Contents_key.t + and type node_key = Node_key.t + + module Portable : + Portable + with type node := t + and type step := step + and type metadata := metadata + and type hash := hash +end + +module type Store = sig + include Indexable.S + + module Path : Path.S + (** [Path] provides base functions on node paths. *) + + val merge : [> read_write ] t -> key option Merge.t + (** [merge] is the 3-way merge function for nodes keys. *) + + module Metadata : Metadata.S + (** [Metadata] provides base functions for node metadata. *) + + (** [Val] provides base functions for node values. *) + module Val : + S_generic_key + with type t = value + and type hash = hash + and type node_key = key + and type metadata = Metadata.t + and type step = Path.step + + module Hash : Hash.Typed with type t = hash and type value = value + + module Contents : Contents.Store with type key = Val.contents_key + (** [Contents] is the underlying contents store. *) +end + +module type Graph = sig + (** {1 Node Graphs} *) + + type 'a t + (** The type for store handles. *) + + type metadata [@@deriving irmin] + (** The type for node metadata. *) + + type contents_key [@@deriving irmin] + (** The type of user-defined contents. *) + + type node_key [@@deriving irmin] + (** The type for node values. *) + + type step [@@deriving irmin] + (** The type of steps. A step is used to pass from one node to another. *) + + type path [@@deriving irmin] + (** The type of store paths. A path is composed of {{!step} steps}. *) + + type value = [ `Node of node_key | `Contents of contents_key * metadata ] + [@@deriving irmin] + (** The type for store values. *) + + val empty : [> write ] t -> node_key Lwt.t + (** The empty node. *) + + val v : [> write ] t -> (step * value) list -> node_key Lwt.t + (** [v t n] is a new node containing [n]. *) + + val list : [> read ] t -> node_key -> (step * value) list Lwt.t + (** [list t n] is the contents of the node [n]. *) + + val find : [> read ] t -> node_key -> path -> value option Lwt.t + (** [find t n p] is the contents of the path [p] starting form [n]. *) + + val add : [> read_write ] t -> node_key -> path -> value -> node_key Lwt.t + (** [add t n p v] is the node [x] such that [find t x p] is [Some v] and it + behaves the same [n] for other operations. *) + + val remove : [> read_write ] t -> node_key -> path -> node_key Lwt.t + (** [remove t n path] is the node [x] such that [find t x] is [None] and it + behhaves then same as [n] for other operations. *) + + val closure : + [> read ] t -> min:node_key list -> max:node_key list -> node_key list Lwt.t + (** [closure t min max] is the unordered list of nodes [n] reachable from a + node of [max] along a path which: (i) either contains no [min] or (ii) it + ends with a [min]. + + {b Note:} Both [min] and [max] are subsets of [n]. *) + + val iter : + [> read ] t -> + min:node_key list -> + max:node_key list -> + ?node:(node_key -> unit Lwt.t) -> + ?contents:(contents_key -> unit Lwt.t) -> + ?edge:(node_key -> node_key -> unit Lwt.t) -> + ?skip_node:(node_key -> bool Lwt.t) -> + ?skip_contents:(contents_key -> bool Lwt.t) -> + ?rev:bool -> + unit -> + unit Lwt.t + (** [iter t min max node edge skip rev ()] iterates in topological order over + the closure of [t]. + + It applies the following functions while traversing the graph: [node] on + the nodes; [edge n predecessor_of_n] on the directed edges; [skip_node n] + to not include a node [n], its predecessors and the outgoing edges of [n] + and [skip_contents c] to not include content [c]. + + If [rev] is true (the default) then the graph is traversed in the reverse + order: [node n] is applied only after it was applied on all its + predecessors; [edge n p] is applied after [node n]. Note that [edge n p] + is applied even if [p] is skipped. *) +end + +module type Sigs = sig + module type S = S + + (** [Make] provides a simple node implementation, parameterized by hash, path + and metadata implementations. The contents and node values are addressed + directly by their hash. *) + module Make + (Hash : Hash.S) (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) : + S + with type hash = Hash.t + and type metadata = Metadata.t + and type step = Path.step + + (** [Generic_key] generalises the concept of "node" to one that supports + object keys that are not strictly equal to hashes. *) + module Generic_key : sig + module type S = S_generic_key + module type Maker = Maker_generic_key + module type Core = Core + + module Make : Maker + + module Make_v2 : Maker + (** [Make_v2] provides a similar implementation as [Make] but the hash + computation is compatible with versions older than irmin.3.0 *) + + module Store + (C : Contents.Store) + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (V : S + with type t = S.value + and type hash = H.t + and type contents_key = C.key + and type node_key = S.key) + (M : Metadata.S with type t = V.metadata) + (P : Path.S with type step = V.step) : + Store + with type 'a t = 'a C.t * 'a S.t + and type key = S.key + and type hash = S.hash + and type value = S.value + and module Path = P + and module Metadata = M + and module Val = V + end + + (** v1 serialisation *) + module V1 (N : Generic_key.S with type step = string) : sig + include + Generic_key.S + with type contents_key = N.contents_key + and type node_key = N.node_key + and type step = N.step + and type metadata = N.metadata + + val import : N.t -> t + val export : t -> N.t + end + + module Portable : sig + (** Portable form of a node implementation that can be constructed from a + concrete representation and used in computing hashes. Conceptually, a + [Node.Portable.t] is a [Node.t] in which all internal keys have been + replaced with the hashes of the values they point to. + + Computations over [Portable.t] values must commute with those over [t]s, + as in the following diagram: + + {[ + ┌────────┐ ┌─────────┐ of_node ┌────────────────┐ + │ Key │ │ Node │ ─────────> │ Node.Portable │ + └────────┘ └─────────┘ └────────────────┘ + │ │ add/remove │ │ + to_hash └───────────> (+) add/remove │ + │ ┌──────────────┼──────────────────────> (+) + v │ v v + ┌────────┐ ┌─────────┐ ┌────────────────┐ + │ Hash │ │ Node' │ ─────────> │ Node.Portable' │ + └────────┘ └─────────┘ of_node └────────────────┘ + ]} *) + + (** A node implementation with hashes for keys is trivially portable: *) + module Of_node (S : S) : + Portable + with type node := S.t + and type t = S.t + and type step = S.step + and type metadata = S.metadata + and type hash = S.hash + + module type S = Portable + end + + module type Store = Store + (** [Store] specifies the signature for node stores. *) + + (** [Store] creates node stores. *) + module Store + (C : Contents.Store) + (S : Content_addressable.S with type key = C.key) + (H : Hash.S with type t = S.key) + (V : S with type t = S.value and type hash = S.key) + (M : Metadata.S with type t = V.metadata) + (P : Path.S with type step = V.step) : + Store + with type 'a t = 'a C.t * 'a S.t + and type key = S.key + and type value = S.value + and type hash = H.t + and module Path = P + and module Metadata = M + and module Val = V + + module type Graph = Graph + (** [Graph] specifies the signature for node graphs. A node graph is a + deterministic DAG, labeled by steps. *) + + module Graph (N : Store) : + Graph + with type 'a t = 'a N.t + and type contents_key = N.Contents.key + and type node_key = N.key + and type metadata = N.Metadata.t + and type step = N.Path.step + and type path = N.Path.t +end diff --git a/vendors/irmin/src/irmin/object_graph.ml b/vendors/irmin/src/irmin/object_graph.ml new file mode 100644 index 0000000000000000000000000000000000000000..bb47a16371d5c6412e50f333053132e58f434a50 --- /dev/null +++ b/vendors/irmin/src/irmin/object_graph.ml @@ -0,0 +1,291 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Object_graph_intf + +let src = Logs.Src.create "irmin.graph" ~doc:"Irmin graph support" + +module Log = (val Logs.src_log src : Logs.LOG) + +let list_partition_map f t = + let rec aux fst snd = function + | [] -> (List.rev fst, List.rev snd) + | h :: t -> ( + match f h with + | `Fst x -> aux (x :: fst) snd t + | `Snd x -> aux fst (x :: snd) t) + in + aux [] [] t + +module Make + (Contents_key : Type.S) + (Node_key : Type.S) + (Commit_key : Type.S) + (Branch : Type.S) = +struct + module X = struct + type t = + [ `Contents of Contents_key.t + | `Node of Node_key.t + | `Commit of Commit_key.t + | `Branch of Branch.t ] + [@@deriving irmin] + + let equal = Type.(unstage (equal t)) + let compare = Type.(unstage (compare t)) + let hash_contents = Type.(unstage (short_hash Contents_key.t)) + let hash_commit = Type.(unstage (short_hash Commit_key.t)) + let hash_node = Type.(unstage (short_hash Node_key.t)) + let hash_branch = Type.(unstage (short_hash Branch.t)) + + (* we are using cryptographic hashes here, so the first bytes + are good enough to be used as short hashes. *) + let hash (t : t) : int = + match t with + | `Contents c -> hash_contents c + | `Node n -> hash_node n + | `Commit c -> hash_commit c + | `Branch b -> hash_branch b + end + + module G = Graph.Imperative.Digraph.ConcreteBidirectional (X) + module GO = Graph.Oper.I (G) + module Topological = Graph.Topological.Make (G) + + module Table : sig + type t + + val create : int option -> t + val add : t -> X.t -> int -> unit + val mem : t -> X.t -> bool + end = struct + module Lru = Lru.Make (X) + module Tbl = Hashtbl.Make (X) + + type t = L of int Lru.t | T of int Tbl.t + + let create = function + | None -> T (Tbl.create 1024) + | Some n -> L (Lru.create n) + + let add t k v = match t with L t -> Lru.add t k v | T t -> Tbl.add t k v + let mem t k = match t with L t -> Lru.mem t k | T t -> Tbl.mem t k + end + + module Set = Set.Make (X) + include G + include GO + + type dump = vertex list * (vertex * vertex) list + + (* XXX: for the binary format, we can use offsets in the vertex list + to save space. *) + module Dump = struct + type t = X.t list * (X.t * X.t) list [@@deriving irmin] + end + + let vertex g = G.fold_vertex (fun k set -> k :: set) g [] + let edges g = G.fold_edges (fun k1 k2 list -> (k1, k2) :: list) g [] + let pp_vertices = Fmt.Dump.list (Type.pp X.t) + let pp_depth ppf d = if d <> max_int then Fmt.pf ppf "depth=%d,@ " d + + type action = Visit of (X.t * int) | Treat of X.t + + let iter ?cache_size ?(depth = max_int) ~pred ~min ~max ~node ?edge ~skip ~rev + () = + [%log.debug + "@[<2>iter:@ %arev=%b,@ min=%a,@ max=%a@, cache=%a@]" pp_depth depth rev + pp_vertices min pp_vertices max + Fmt.(Dump.option int) + cache_size]; + let marks = Table.create cache_size in + let mark key level = Table.add marks key level in + let todo = Stack.create () in + (* if a branch is in [min], add the commit it is pointing to too. *) + let* min = + Lwt_list.fold_left_s + (fun acc -> function + | `Branch _ as x -> pred x >|= fun c -> (x :: c) @ acc + | x -> Lwt.return (x :: acc)) + [] min + in + let min = Set.of_list min in + let has_mark key = Table.mem marks key in + List.iter (fun k -> Stack.push (Visit (k, 0)) todo) max; + let treat key = + [%log.debug "TREAT %a" Type.(pp X.t) key]; + node key >>= fun () -> + if not (Set.mem key min) then + (* the edge function is optional to prevent an unnecessary computation + of the preds .*) + match edge with + | None -> Lwt.return_unit + | Some edge -> + let* keys = pred key in + Lwt_list.iter_p (fun k -> edge key k) keys + else Lwt.return_unit + in + let visit_predecessors ~filter_history key level = + let+ keys = pred key in + (*if a commit is in [min] cut the history but still visit + its nodes. *) + List.iter + (function + | `Commit _ when filter_history -> () + | k -> Stack.push (Visit (k, level + 1)) todo) + keys + in + let visit key level = + if level >= depth then Lwt.return_unit + else if has_mark key then Lwt.return_unit + else + skip key >>= function + | true -> Lwt.return_unit + | false -> + let+ () = + [%log.debug "VISIT %a %d" Type.(pp X.t) key level]; + mark key level; + if rev then Stack.push (Treat key) todo; + match key with + | `Commit _ -> + visit_predecessors ~filter_history:(Set.mem key min) key level + | _ -> + if Set.mem key min then Lwt.return_unit + else visit_predecessors ~filter_history:false key level + in + if not rev then Stack.push (Treat key) todo + in + let rec pop () = + match Stack.pop todo with + | exception Stack.Empty -> Lwt.return_unit + | Treat key -> treat key >>= pop + | Visit (key, level) -> visit key level >>= pop + in + pop () + + let breadth_first_traversal ?cache_size ~pred ~max ~node () = + let marks = Table.create cache_size in + let mark key level = Table.add marks key level in + let todo = Queue.create () in + let has_mark key = Table.mem marks key in + List.iter (fun k -> Queue.push (Visit (k, 0)) todo) max; + let treat key = + [%log.debug "TREAT %a" Type.(pp X.t) key]; + node key + in + let visit_predecessors key level = + let+ keys = pred key in + List.iter (fun k -> Queue.push (Visit (k, level + 1)) todo) keys + in + let visit key level = + if has_mark key then Lwt.return_unit + else ( + [%log.debug "VISIT %a" Type.(pp X.t) key]; + mark key level; + treat key >>= fun () -> visit_predecessors key level) + in + let rec pop () = + match Queue.pop todo with + | exception Queue.Empty -> Lwt.return_unit + | Treat _ -> + Fmt.failwith "in bfs always treat the node as soon as its visited" + | Visit (key, level) -> visit key level >>= pop + in + pop () + + let closure ?(depth = max_int) ~pred ~min ~max () = + let g = G.create ~size:1024 () in + List.iter (G.add_vertex g) max; + let node key = + if not (G.mem_vertex g key) then G.add_vertex g key else (); + Lwt.return_unit + in + let edge node pred = + G.add_edge g pred node; + Lwt.return_unit + in + let skip _ = Lwt.return_false in + iter ~depth ~pred ~min ~max ~node ~edge ~skip ~rev:false () >|= fun () -> g + + let min g = + G.fold_vertex + (fun v acc -> if G.in_degree g v = 0 then v :: acc else acc) + g [] + + let max g = + G.fold_vertex + (fun v acc -> if G.out_degree g v = 0 then v :: acc else acc) + g [] + + let vertex_attributes = ref (fun _ -> []) + let edge_attributes = ref (fun _ -> []) + let graph_name = ref None + + module Dot = Graph.Graphviz.Dot (struct + include G + + let edge_attributes k = !edge_attributes k + let default_edge_attributes _ = [] + + let vertex_name k = + let str t v = "\"" ^ Type.to_string t v ^ "\"" in + match k with + | `Node n -> str Node_key.t n + | `Commit c -> str Commit_key.t c + | `Contents c -> str Contents_key.t c + | `Branch b -> str Branch.t b + + let vertex_attributes k = !vertex_attributes k + let default_vertex_attributes _ = [] + let get_subgraph _ = None + + let graph_attributes _ = + match !graph_name with None -> [] | Some n -> [ `Label n ] + end) + + let export t = (vertex t, edges t) + + let import (vs, es) = + let g = G.create ~size:(List.length vs) () in + List.iter (G.add_vertex g) vs; + List.iter (fun (v1, v2) -> G.add_edge g v1 v2) es; + g + + let output ppf vertex edges name = + [%log.debug "output %s" name]; + let g = G.create ~size:(List.length vertex) () in + List.iter (fun (v, _) -> G.add_vertex g v) vertex; + List.iter (fun (v1, _, v2) -> G.add_edge g v1 v2) edges; + let eattrs (v1, v2) = + try + let l = List.filter (fun (x, _, y) -> x = v1 && y = v2) edges in + let l = List.fold_left (fun acc (_, l, _) -> l @ acc) [] l in + let labels, others = + list_partition_map (function `Label l -> `Fst l | x -> `Snd x) l + in + match labels with + | [] -> others + | [ l ] -> `Label l :: others + | _ -> `Label (String.concat "," labels) :: others + with Not_found -> [] + in + let vattrs v = try List.assoc v vertex with Not_found -> [] in + vertex_attributes := vattrs; + edge_attributes := eattrs; + graph_name := Some name; + Dot.fprint_graph ppf g +end diff --git a/vendors/irmin/src/irmin/object_graph.mli b/vendors/irmin/src/irmin/object_graph.mli new file mode 100644 index 0000000000000000000000000000000000000000..a16412aaa26742e355255c92eb25fd963c435c31 --- /dev/null +++ b/vendors/irmin/src/irmin/object_graph.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Graphs. *) + +include Object_graph_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/object_graph_intf.ml b/vendors/irmin/src/irmin/object_graph_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..063c3bbe0b383b8066289e18b0bb26514ce26d03 --- /dev/null +++ b/vendors/irmin/src/irmin/object_graph_intf.ml @@ -0,0 +1,139 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + include Graph.Sig.I + (** Directed graph *) + + include Graph.Oper.S with type g := t + (** Basic operations. *) + + (** Topological traversal *) + module Topological : sig + val fold : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + end + + val vertex : t -> vertex list + (** Get all the vertices. *) + + val edges : t -> (vertex * vertex) list + (** Get all the relations. *) + + val closure : + ?depth:int -> + pred:(vertex -> vertex list Lwt.t) -> + min:vertex list -> + max:vertex list -> + unit -> + t Lwt.t + (** [closure depth pred min max ()] creates the transitive closure graph of + [max] using the predecessor relation [pred]. The graph is bounded by the + [min] nodes and by [depth]. + + {b Note:} Both [min] and [max] are subsets of [n]. *) + + val iter : + ?cache_size:int -> + ?depth:int -> + pred:(vertex -> vertex list Lwt.t) -> + min:vertex list -> + max:vertex list -> + node:(vertex -> unit Lwt.t) -> + ?edge:(vertex -> vertex -> unit Lwt.t) -> + skip:(vertex -> bool Lwt.t) -> + rev:bool -> + unit -> + unit Lwt.t + (** [iter depth min max node edge skip rev ()] iterates in topological order + over the closure graph starting with the [max] nodes and bounded by the + [min] nodes and by [depth]. + + It applies three functions while traversing the graph: [node] on the + nodes; [edge n predecessor_of_n] on the directed edges and [skip n] to not + include a node [n], its predecessors and the outgoing edges of [n]. + + If [rev] is true (the default) then the graph is traversed in the reverse + order: [node n] is applied only after it was applied on all its + predecessors; [edge n p] is applied after [node n]. Note that [edge n p] + is applied even if [p] is skipped. + + [cache_size] is the size of the LRU cache used to store nodes already + seen. If [None] (by default) every traversed nodes is stored (and thus no + entries are never removed from the LRU). *) + + val breadth_first_traversal : + ?cache_size:int -> + pred:(vertex -> vertex list Lwt.t) -> + max:vertex list -> + node:(vertex -> unit Lwt.t) -> + unit -> + unit Lwt.t + (** [breadth_first_traversal ?cache_size pred max node ()] traverses the + closure graph in breadth-first order starting with the [max] nodes. It + applies [node] on the nodes of the graph while traversing it. *) + + val output : + Format.formatter -> + (vertex * Graph.Graphviz.DotAttributes.vertex list) list -> + (vertex * Graph.Graphviz.DotAttributes.edge list * vertex) list -> + string -> + unit + (** [output ppf vertex edges name] create aand dumps the graph contents on + [ppf]. The graph is defined by its [vertex] and [edges]. [name] is the + name of the output graph.*) + + val min : t -> vertex list + (** Compute the minimum vertex. *) + + val max : t -> vertex list + (** Compute the maximun vertex. *) + + type dump = vertex list * (vertex * vertex) list + (** Expose the graph internals. *) + + val export : t -> dump + (** Expose the graph as a pair of vertices and edges. *) + + val import : dump -> t + (** Import a graph. *) + + module Dump : Type.S with type t = dump + (** The base functions over graph internals. *) +end + +module type HASH = sig + include Type.S + + val short_hash : t -> int +end + +module type Sigs = sig + module type S = S + module type HASH = HASH + + (** Build a graph. *) + module Make + (Contents_key : Type.S) + (Node_key : Type.S) + (Commit_key : Type.S) + (Branch : Type.S) : + S + with type V.t = + [ `Contents of Contents_key.t + | `Node of Node_key.t + | `Commit of Commit_key.t + | `Branch of Branch.t ] +end diff --git a/vendors/irmin/src/irmin/path.ml b/vendors/irmin/src/irmin/path.ml new file mode 100644 index 0000000000000000000000000000000000000000..95b73760b6d001af74e9b89de325a1fc9b5861d5 --- /dev/null +++ b/vendors/irmin/src/irmin/path.ml @@ -0,0 +1,48 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Astring +include Path_intf + +module String_list = struct + type step = string [@@deriving irmin] + type t = step list + + let empty = [] + let is_empty l = l = [] + let cons s t = s :: t + let rcons t s = t @ [ s ] + let decons = function [] -> None | h :: t -> Some (h, t) + + let rdecons l = + match List.rev l with [] -> None | h :: t -> Some (List.rev t, h) + + let map l f = List.map f l + let v x = x + + let pp ppf t = + let len = List.fold_left (fun acc s -> 1 + acc + String.length s) 1 t in + let buf = Buffer.create len in + List.iter + (fun s -> + Buffer.add_char buf '/'; + Buffer.add_string buf s) + t; + Fmt.string ppf (Buffer.contents buf) + + let of_string s = Ok (List.filter (( <> ) "") (String.cuts s ~sep:"/")) + let t = Type.like ~pp ~of_string Type.(list step_t) +end diff --git a/vendors/irmin/src/irmin/path.mli b/vendors/irmin/src/irmin/path.mli new file mode 100644 index 0000000000000000000000000000000000000000..32c9de496f5fd89828011668bfefc3feec667ed9 --- /dev/null +++ b/vendors/irmin/src/irmin/path.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Tree path handling. *) + +include Path_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/path_intf.ml b/vendors/irmin/src/irmin/path_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..9ff994bff53fbdf903f4da9593089d938da01b68 --- /dev/null +++ b/vendors/irmin/src/irmin/path_intf.ml @@ -0,0 +1,67 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Path} *) + + type t + (** The type for path values. *) + + type step + (** Type type for path's steps. *) + + val empty : t + (** The empty path. *) + + val v : step list -> t + (** Create a path from a list of steps. *) + + val is_empty : t -> bool + (** Check if the path is empty. *) + + val cons : step -> t -> t + (** Prepend a step to the path. *) + + val rcons : t -> step -> t + (** Append a step to the path. *) + + val decons : t -> (step * t) option + (** Deconstruct the first element of the path. Return [None] if the path is + empty. *) + + val rdecons : t -> (t * step) option + (** Deconstruct the last element of the path. Return [None] if the path is + empty. *) + + val map : t -> (step -> 'a) -> 'a list + (** [map t f] maps [f] over all steps of [t]. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!type-t}. *) + + val step_t : step Type.t + (** [step_t] is the value type for {!step}. *) +end + +module type Sigs = sig + module type S = S + (** Signature for path implementations.*) + + (** An implementation of paths as string lists. *) + module String_list : S with type step = string and type t = string list +end diff --git a/vendors/irmin/src/irmin/perms.ml b/vendors/irmin/src/irmin/perms.ml new file mode 100644 index 0000000000000000000000000000000000000000..1d66477f05f90d922c40474dbfd8e19afc618804 --- /dev/null +++ b/vendors/irmin/src/irmin/perms.ml @@ -0,0 +1,66 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Types representing {i permissions} ['perms] for performing operations on a + certain type ['perms t]. + + They are intended to be used as phantom parameters of the types that they + control access to. As an example, consider the following type of references + with permissions: + + {[ + module Ref : sig + type (+'a, -'perms) t + + val create : 'a -> ('a, read_write) t + val get : ('a, [> read ]) t -> 'a + val set : ('a, [> write ]) t -> 'a -> unit + end + ]} + + This type allows references to be created with arbitrary read-write access. + One can then create weaker views onto the reference – with access to fewer + operations – by upcasting: + + {[ + let read_only t = (t :> (_, read) Ref.t) + let write_only t = (t :> (_, write) Ref.t) + ]} + + Note that the ['perms] phantom type parameter should be contravariant: it's + safe to discard permissions, but not to gain new ones. *) + +module Read = struct + type t = [ `Read ] +end + +module Write = struct + type t = [ `Write ] +end + +module Read_write = struct + type t = [ Read.t | Write.t ] +end + +type read = Read.t +(** The type parameter of a handle with [read] permissions. *) + +type write = Write.t +(** The type parameter of a handle with [write] permissions. *) + +type read_write = Read_write.t +(** The type parameter of a handle with both {!read} and {!write} permissions. *) diff --git a/vendors/irmin/src/irmin/proof.ml b/vendors/irmin/src/irmin/proof.ml new file mode 100644 index 0000000000000000000000000000000000000000..65481e0011643d7fc6a271363057569ddd349ba3 --- /dev/null +++ b/vendors/irmin/src/irmin/proof.ml @@ -0,0 +1,658 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Proof_intf + +module Make + (C : Type.S) + (H : Type.S) (S : sig + type step [@@deriving irmin] + end) + (M : Type.S) = +struct + type contents = C.t [@@deriving irmin] + type hash = H.t [@@deriving irmin] + type step = S.step [@@deriving irmin] + type metadata = M.t [@@deriving irmin] + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + + type 'a inode = { length : int; proofs : (int * 'a) list } [@@deriving irmin] + + type 'a inode_extender = { length : int; segments : int list; proof : 'a } + [@@deriving irmin] + + type tree = + | Contents of contents * metadata + | Blinded_contents of hash * metadata + | Node of (step * tree) list + | Blinded_node of hash + | Inode of inode_tree inode + | Extender of inode_tree inode_extender + [@@deriving irmin] + + and inode_tree = + | Blinded_inode of hash + | Inode_values of (step * tree) list + | Inode_tree of inode_tree inode + | Inode_extender of inode_tree inode_extender + [@@deriving irmin] + + type elt = + | Contents of contents + | Node of (step * kinded_hash) list + | Inode of hash inode + | Inode_extender of hash inode_extender + [@@deriving irmin] + + type stream = elt Seq.t [@@deriving irmin] + + type 'a t = { before : kinded_hash; after : kinded_hash; state : 'a } + [@@deriving irmin] + + let before t = t.before + let after t = t.after + let state t = t.state + let v ~before ~after state = { after; before; state } +end + +type bad_stream_exn = + | Stream_too_long of { context : string; reason : string } + | Stream_too_short of { context : string; reason : string } + | Proof_mismatch of { context : string; reason : string } + +exception Bad_proof of { context : string } +exception Bad_stream of bad_stream_exn + +let bad_proof_exn context = raise (Bad_proof { context }) + +let bad_stream_too_long context reason = + raise (Bad_stream (Stream_too_long { context; reason })) + +let bad_stream_too_short context reason = + raise (Bad_stream (Stream_too_short { context; reason })) + +let bad_stream_exn context reason = + raise (Bad_stream (Proof_mismatch { context; reason })) + +let bad_stream_exn_fmt s fmt = Fmt.kstr (bad_stream_exn ("Proof.Env." ^ s)) fmt + +let bad_stream_too_short_fmt s fmt = + Fmt.kstr (bad_stream_too_short ("Proof.Env." ^ s)) fmt + +module Env + (B : Backend.S) + (P : S + with type contents := B.Contents.Val.t + and type hash := B.Hash.t + and type step := B.Node.Val.step + and type metadata := B.Node.Val.metadata) = +struct + module H = B.Hash + + module Hashes = struct + include Hashtbl.Make (struct + type t = H.t + + let hash = H.short_hash + let equal = Type.(unstage (equal H.t)) + end) + + let of_list l = of_seq (List.to_seq l) + let to_list t = List.of_seq (to_seq t) + let t elt_t = Type.map [%typ: (H.t * elt) list] of_list to_list + end + + type mode = Produce | Serialise | Deserialise | Consume [@@deriving irmin] + type kind = Set | Stream [@@deriving irmin] + + module Set = struct + type produce = { + nodes : B.Node.Val.t Hashes.t; + contents : B.Contents.Val.t Hashes.t; + } + [@@deriving irmin] + + type deserialise = { + nodes : B.Node_portable.t Hashes.t; + contents : B.Contents.Val.t Hashes.t; + } + [@@deriving irmin] + + type t = + | Produce of produce + | Serialise of produce + | Deserialise of deserialise + | Consume of deserialise + [@@deriving irmin] + + let producer () = + Produce { contents = Hashes.create 13; nodes = Hashes.create 13 } + + let deserialiser () = + Deserialise { contents = Hashes.create 13; nodes = Hashes.create 13 } + end + + module Stream = struct + let ref_t v = Type.map v ref ( ! ) + + type produce = { + set : unit Hashes.t; + singleton_inodes : (int * H.t) Hashes.t; + rev_elts : (H.t * P.elt) list ref; + rev_elts_size : int ref; + } + [@@deriving irmin] + + type consume = { + nodes : B.Node_portable.t Hashes.t; + contents : B.Contents.Val.t Hashes.t; + stream : P.elt Seq.t ref; + } + [@@deriving irmin] + + type t = Produce of produce | Consume of consume [@@deriving irmin] + + let producer () = + let set = Hashes.create 13 in + let singleton_inodes = Hashes.create 13 in + let rev_elts = ref [] in + let rev_elts_size = ref 0 in + Produce { set; singleton_inodes; rev_elts; rev_elts_size } + + let consumer stream = + let nodes = Hashes.create 13 in + let contents = Hashes.create 13 in + let stream = ref stream in + Consume { nodes; contents; stream } + + let push { rev_elts; rev_elts_size; _ } h_elt index = + incr rev_elts_size; + rev_elts := List.insert_exn !rev_elts index h_elt + end + + type v = Empty | Set of Set.t | Stream of Stream.t [@@deriving irmin] + type t = v ref + + let t = Type.map v_t ref ( ! ) + let empty () : t = ref Empty + let is_empty t = !t = Empty + let copy ~into t = into := !t + + type hash = H.t [@@deriving irmin ~equal ~pp] + + let rec forward_lookup h singleton_inodes : (int * hash) list option = + match Hashes.find_opt singleton_inodes h with + | None -> None + | Some (i', h') -> ( + match forward_lookup h' singleton_inodes with + | None -> Some [ (i', h') ] + | Some l -> Some ((i', h') :: l)) + + let apply_extenders ~length singleton_inodes skips proofs = + let rec accumulate_segments ~(acc : int Reversed_list.t) h = function + | [] -> (Reversed_list.rev acc, h) + | (i', h') :: rest -> accumulate_segments ~acc:(i' :: acc) h' rest + in + let inode = P.Inode { length; proofs } in + match proofs with + | [ (i, h) ] -> ( + match forward_lookup h singleton_inodes with + | None -> inode + | Some ls -> ( + let () = + (* Push all hashes except the last one into [skips] *) + match List.rev ((i, h) :: ls) with + | [] | [ _ ] -> failwith "idk" + | _ :: tl -> List.iter (fun (_, h) -> Hashes.add skips h ()) tl + in + let i, h = accumulate_segments ~acc:[ i ] h ls in + match i with + | [] | [ _ ] -> assert false + | segments -> P.Inode_extender { length; segments; proof = h })) + | _ -> inode + + let post_processing singleton_inodes (stream : (hash * P.elt) list) : + P.elt list = + let skips = Hashes.create 13 in + (* [skips] are the elements of the [stream] that are included in the + extenders, they will be removed from the final stream. *) + let rec aux rev_elts = function + | [] -> List.rev rev_elts + | (h, elt) :: rest -> + if Hashes.mem skips h then aux rev_elts rest + else + let elt' : P.elt = + match (elt : P.elt) with + | P.Inode { length; proofs } -> + apply_extenders ~length singleton_inodes skips proofs + | Node ls -> Node ls + | Contents c -> Contents c + | Inode_extender _ -> assert false + in + aux (elt' :: rev_elts) rest + in + aux [] stream + + let to_stream t = + match !t with + | Stream (Produce { rev_elts; singleton_inodes; _ }) -> + List.rev !rev_elts |> post_processing singleton_inodes |> List.to_seq + | _ -> assert false + + let is_empty_stream t = + match !t with + | Stream (Consume { stream; _ }) -> ( + (* Peek the sequence but do not advance the ref *) + match !stream () with Seq.Nil -> true | _ -> false) + | _ -> false + + let set_mode t (kind : kind) mode = + match kind with + | Set -> ( + match (!t, mode) with + | Empty, Produce -> t := Set Set.(producer ()) + | Empty, Deserialise -> t := Set Set.(deserialiser ()) + | Set (Produce set), Serialise -> t := Set Set.(Serialise set) + | Set (Deserialise set), Consume -> t := Set Set.(Consume set) + | _ -> assert false) + | Stream -> ( + match (!t, mode) with + | Empty, Produce -> t := Stream (Stream.producer ()) + | _ -> assert false) + + let with_set_consume f = + let t = ref Empty in + set_mode t Set Deserialise; + let stop_deserialise () = set_mode t Set Consume in + let+ res = f t ~stop_deserialise in + t := Empty; + res + + let with_set_produce f = + let t = ref Empty in + set_mode t Set Produce; + let start_serialise () = set_mode t Set Serialise in + let+ res = f t ~start_serialise in + t := Empty; + res + + let with_stream_produce f = + let t = ref Empty in + set_mode t Stream Produce; + let to_stream () = to_stream t in + let+ res = f t ~to_stream in + t := Empty; + res + + let with_stream_consume stream f = + let t = Stream (Stream.consumer stream) |> ref in + let is_empty () = is_empty_stream t in + let+ res = f t ~is_empty in + t := Empty; + res + + module Contents_hash = Hash.Typed (H) (B.Contents.Val) + + let check_contents_integrity v h = + let h' = Contents_hash.hash v in + if not (equal_hash h' h) then + bad_stream_exn_fmt "check_contents_integrity" "got %a expected %a" pp_hash + h' pp_hash h + + let check_node_integrity v h = + let h' = + try B.Node_portable.hash_exn ~force:false v + with Not_found -> + (* [v] is out of [of_proof], it is supposed to have its hash available + without IOs. + + If these IOs were to occur, it would corrupt the stream being read. + *) + assert false + in + if not (equal_hash h' h) then + bad_stream_exn_fmt "check_node_integrity" "got %a expected %a" pp_hash h' + pp_hash h + + let dehydrate_stream_node v = + (* [v] is fresh out of the node store, meaning that if it is represented + recursively it is still in a shallow state. + + [head v] might trigger IOs. It is fine because [v] is already wrapped + with [with_handler]. *) + match B.Node.Val.head v with + | `Node l -> + let l = + List.map + (function + | step, `Contents (k, m) -> + (step, `Contents (B.Contents.Key.to_hash k, m)) + | step, `Node k -> (step, `Node (B.Node.Key.to_hash k))) + l + in + P.Node l + | `Inode (length, proofs) -> P.Inode { length; proofs } + + let rehydrate_stream_node ~depth (elt : P.elt) h = + let bad_stream_exn_fmt = bad_stream_exn_fmt "rehydrate_stream_node" in + match elt with + | Contents _ -> + bad_stream_exn_fmt + "found contents at depth %d when looking for node with hash %a" depth + pp_hash h + | Node l -> ( + match B.Node_portable.of_proof ~depth (`Values l) with + | Some v -> v + | None -> + bad_stream_exn_fmt + "could not deserialise Node at depth %d when looking for hash %a" + depth pp_hash h) + | Inode { length; proofs } -> + let proofs = List.map (fun (i, h) -> (i, `Blinded h)) proofs in + let inode = `Inode (length, proofs) in + let v = + match B.Node_portable.of_proof ~depth inode with + | Some v -> v + | None -> + bad_stream_exn_fmt + "could not deserialise Inode at depth %d when looking for hash \ + %a" + depth pp_hash h + in + v + | Inode_extender { length; segments; proof } -> + let elt = + List.fold_left + (fun acc i -> `Inode (length, [ (i, acc) ])) + (`Blinded proof) (List.rev segments) + in + let v = + match B.Node_portable.of_proof ~depth elt with + | Some v -> v + | None -> + bad_stream_exn_fmt + "could not deserialise Inode at depth %d when looking for hash \ + %a" + depth pp_hash h + in + v + + let rehydrate_stream_contents (elt : P.elt) h = + let err k = + bad_stream_exn_fmt "find_contents" + "found %s when looking Contents with hash %a" k pp_hash h + in + match elt with + | Node _ -> err "Node" + | Inode _ -> err "Inode" + | Inode_extender _ -> err "Inode" + | Contents v -> v + + let find_contents t h = + match !t with + | Empty -> None + | Set (Produce set) -> + (* Sharing of contents is not strictly needed during this phase. It + could be disabled. *) + Hashes.find_opt set.contents h + | Set (Serialise set) -> + (* This is needed in order to differenciate between blinded contents + from others. *) + Hashes.find_opt set.contents h + | Set (Deserialise _) -> + (* This phase only fills the env, it should search for anything *) + assert false + | Set (Consume set) -> + (* Use the Env to feed the values during consume *) + Hashes.find_opt set.contents h + | Stream (Produce _) -> + (* There is no need for sharing with stream proofs *) + None + | Stream (Consume { contents; stream; _ }) -> ( + (* Use the Env to feed the values during consume *) + match Hashes.find_opt contents h with + | Some v -> Some v + | None -> ( + match !stream () with + | Seq.Nil -> + bad_stream_too_short_fmt "find_contents" + "empty stream when looking for hash %a" pp_hash h + | Cons (elt, rest) -> + let v = rehydrate_stream_contents elt h in + check_contents_integrity v h; + stream := rest; + Hashes.add contents h v; + Some v)) + + let add_contents_from_store t h v = + match !t with + | Empty -> () + | Set (Produce set) -> + (* Registering in [set] for traversal during [Serialise]. *) + assert (not (Hashes.mem set.contents h)); + Hashes.add set.contents h v + | Set (Serialise _) -> + (* There shouldn't be new contents during this phase *) + assert false + | Set (Deserialise _) -> + (* This phase has no repo pointer *) + assert false + | Set (Consume _) -> + (* This phase has no repo pointer *) + assert false + | Stream (Produce ({ set; _ } as cache)) -> + (* Registering when seen for the first time *) + if not @@ Hashes.mem set h then ( + Hashes.add set h (); + let h_elt : hash * P.elt = (h, Contents v) in + Stream.push cache h_elt 0) + | Stream (Consume _) -> + (* This phase has no repo pointer *) + assert false + + let add_contents_from_proof t h v = + match !t with + | Set (Deserialise set) -> + (* Using [replace] because there could be several instances of this + contents in the proof, we will not share as this is not strictly + needed. *) + Hashes.replace set.contents h v + | _ -> assert false + + let find_node t h = + match !t with + | Empty -> None + | Set (Produce set) -> + (* This is needed in order to achieve sharing on inode's pointers. In + other words, each node present in the [before] tree should have a + single [P.Node.Val.t] representative that will witness all the lazy + inode loadings. *) + Hashes.find_opt set.nodes h + | Set (Serialise set) -> + (* This is needed in order to follow loaded paths in the [before] + tree. *) + Hashes.find_opt set.nodes h + | Set (Deserialise _) -> + (* This phase only fills the env, it should search for anything *) + assert false + | Set (Consume _) -> + (* This phase looks for portable nodes *) + None + | Stream (Produce _) -> + (* There is no need for sharing with stream proofs *) + None + | Stream (Consume _) -> + (* This phase looks for portable nodes *) + None + + let find_recpnode t _find ~expected_depth h = + assert (expected_depth > 0); + match !t with + | Stream (Consume { nodes; stream; _ }) -> ( + (* Use the Env to feed the values during consume *) + match Hashes.find_opt nodes h with + | Some v -> Some v + | None -> ( + match !stream () with + | Seq.Nil -> + bad_stream_too_short_fmt "find_recnode" + "empty stream when looking for hash %a" pp_hash h + | Cons (v, rest) -> + let v = rehydrate_stream_node ~depth:expected_depth v h in + (* There is no need to apply [with_handler] here because there + is no repo pointer in this inode. *) + check_node_integrity v h; + stream := rest; + Hashes.add nodes h v; + Some v)) + | _ -> assert false + + let find_pnode t h = + match !t with + | Set (Consume set) -> + (* [set] has been filled during deserialise. Using it to provide values + during consume. *) + Hashes.find_opt set.nodes h + | Stream (Consume { nodes; stream; _ }) -> ( + (* Use the Env to provide the values during consume. Since all hashes + are unique in [stream], [nodes] provides a hash-based sharing. *) + match Hashes.find_opt nodes h with + | Some v -> Some v + | None -> ( + match !stream () with + | Seq.Nil -> + bad_stream_too_short_fmt "find_node" + "empty stream when looking for hash %a" pp_hash h + | Cons (v, rest) -> + (* Shorten [stream] before calling [head] as it might itself + perform reads. *) + stream := rest; + let v = + (* [depth] is 0 because this context deals with root nodes *) + rehydrate_stream_node ~depth:0 v h + in + let v = + (* Call [with_handler] before [head] because the later might + perform reads *) + B.Node_portable.with_handler (find_recpnode t) v + in + let (_ : [ `Node of _ | `Inode of _ ]) = + (* At produce time [dehydrate_stream_node] called [head] which + might have performed IOs. If it did then we must consume + the stream accordingly right now in order to preserve + stream ordering. *) + B.Node_portable.head v + in + check_node_integrity v h; + Hashes.add nodes h v; + + Some v)) + | _ -> None + + let add_recnode_from_store t find ~expected_depth k = + assert (expected_depth > 0); + match !t with + | Stream (Produce ({ set; singleton_inodes; _ } as cache)) -> ( + (* Registering when seen for the first time, there is no need + for sharing. *) + match find ~expected_depth k with + | None -> None + | Some v -> + let h = B.Node.Key.to_hash k in + if not @@ Hashes.mem set h then ( + Hashes.add set h (); + let elt = dehydrate_stream_node v in + let () = + match elt with + | P.Inode { proofs = [ bucket ]; _ } -> + Hashes.add singleton_inodes h bucket + | _ -> () + in + Stream.push cache (h, elt) 0); + Some v) + | _ -> assert false + + let add_node_from_store t h v = + match !t with + | Empty -> v + | Set (Produce set) -> + (* Registering in [set] for sharing during [Produce] and traversal + during [Serialise]. This assertion is guarenteed because + [add_node_from_store] is guarded by a call to [find_node] in tree. *) + assert (not (Hashes.mem set.nodes h)); + Hashes.add set.nodes h v; + v + | Set (Serialise _) -> + (* There shouldn't be new nodes during this phase *) + assert false + | Set (Deserialise _) -> + (* This phase has no repo pointer *) + assert false + | Set (Consume _) -> + (* This phase has no repo pointer *) + assert false + | Stream (Produce ({ set; rev_elts_size; singleton_inodes; _ } as cache)) -> + (* Registering when seen for the first time and wrap its [find] + function. Since there is no sharing during the production of + streamed proofs, the hash may already have been seened. *) + let new_hash = not @@ Hashes.mem set h in + let v = + (* In all case [v] should be wrapped. + If [not new_hash] then wrap it for future IOs on it. + + If [new_hash] then it additionally should be wrapped before + calling [dehydrate_stream_node] as this call may trigger IOs. *) + B.Node.Val.with_handler (add_recnode_from_store t) v + in + if new_hash then ( + Hashes.add set h (); + let len0 = !rev_elts_size in + let elt = dehydrate_stream_node v in + let len1 = !rev_elts_size in + let delta = + (* [delta] is the number of reads that were performed by + [dehydrate_stream_node]. *) + len1 - len0 + in + let () = + match elt with + | P.Inode { proofs = [ bucket ]; _ } -> + Hashes.add singleton_inodes h bucket + | _ -> () + in + (* if [delta = 0] then push the pair at the head of the list. + + if [delta > 0] then insert it before the calls that it triggered. *) + Stream.push cache (h, elt) delta); + v + | Stream (Consume _) -> + (* This phase has no repo pointer *) + assert false + + let add_pnode_from_proof t h v = + match !t with + | Set (Deserialise set) -> + (* Using [replace] because there could be several instances of this + node in the proof, we will not share as this is not strictly + needed. + All the occurences of this node in the proof are expected to have + the same blinded/visible coverage (i.e. the same node proof). *) + Hashes.replace set.nodes h v + | _ -> assert false +end diff --git a/vendors/irmin/src/irmin/proof.mli b/vendors/irmin/src/irmin/proof.mli new file mode 100644 index 0000000000000000000000000000000000000000..d2f22b543f1887c92661fa71800f2262aa666105 --- /dev/null +++ b/vendors/irmin/src/irmin/proof.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Proof_intf.Proof diff --git a/vendors/irmin/src/irmin/proof_intf.ml b/vendors/irmin/src/irmin/proof_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..13858a79818163cc25db78472e96fd6346dd47be --- /dev/null +++ b/vendors/irmin/src/irmin/proof_intf.ml @@ -0,0 +1,357 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** Proofs are compact representations of trees which can be shared between + peers. + + This is expected to be used as follows: + + - A first peer runs a function [f] over a tree [t]. While performing this + computation, it records: the hash of [t] (called [before] below), the + hash of [f t] (called [after] below) and a subset of [t] which is needed + to replay [f] without any access to the first peer's storage. Once done, + all these informations are packed into a proof of type [t] that is sent + to the second peer. + + - The second peer generates an initial tree [t'] from [p] and computes + [f t']. Once done, it compares [t']'s hash and [f t']'s hash to [before] + and [after]. If they match, they know that the result state [f t'] is a + valid context state, without having to have access to the full storage + of the first peer. *) + + type contents + type hash + type step + type metadata + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + + type 'a inode = { length : int; proofs : (int * 'a) list } [@@deriving irmin] + (** The type for (internal) inode proofs. + + These proofs encode large directories into a tree-like structure. + + Invariants are dependent on the backend. + + [length] is the total number of entries in the children of the inode. It's + the size of the "flattened" version of that inode. [length] can be used to + prove the correctness of operations such as [Tree.length] and + [Tree.list ~offset ~length] in an efficient way. + + [proofs] contains the children proofs. It is a sparse list of ['a] values. + These values are associated to their index in the list, and the list is + kept sorted in increasing order of indices. ['a] can be a concrete proof + or a hash of that proof. + + {e For [irmin-pack]}: [proofs] have a length of at most [Conf.entries] + entries. For binary trees, this boolean index is a step of the left-right + sequence / decision proof corresponding to the path in that binary tree. *) + + type 'a inode_extender = { length : int; segments : int list; proof : 'a } + [@@deriving irmin] + (** The type for inode extenders. + + An extender is a compact representation of a sequence of [inode] which + contain only one child. As for inodes, the ['a] parameter can be a + concrete proof or a hash of that proof. + + If an inode proof contains singleton children [i_0, ..., i_n] such as: + [{length=l; proofs = \[ (i_0, {proofs = ... { proofs = \[ (i_n, p) \] }})\]}], + then it is compressed into the inode extender + [{length=l; segment = \[i_0;..;i_n\]; proof=p}] sharing the same length + [l] and final proof [p]. *) + + (** The type for compressed and partial Merkle tree proofs. + + Tree proofs do not provide any guarantee with the ordering of + computations. For instance, if two effects commute, they won't be + distinguishable by this kind of proof. + + [Value v] proves that a value [v] exists in the store. + + [Blinded_value h] proves a value with hash [h] exists in the store. + + [Node ls] proves that a a "flat" node containing the list of files [ls] + exists in the store. {e For [irmin-pack]}: the length of [ls] is at most + [Conf.stable_hash]; + + [Blinded_node h] proves that a node with hash [h] exists in the store. + + [Inode i] proves that an inode [i] exists in the store. + + [Extender e] proves that an inode extender [e] exist in the store. *) + type tree = + | Contents of contents * metadata + | Blinded_contents of hash * metadata + | Node of (step * tree) list + | Blinded_node of hash + | Inode of inode_tree inode + | Extender of inode_tree inode_extender + [@@deriving irmin] + + (** The type for inode trees. It is a subset of [tree], limited to nodes. + + [Blinded_inode h] proves that an inode with hash [h] exists in the store. + + [Inode_values ls] is simliar to trees' [Node]. + + [Inode_tree i] is similar to tree's [Inode]. + + [Inode_extender e] is similar to trees' [Extender]. *) + and inode_tree = + | Blinded_inode of hash + | Inode_values of (step * tree) list + | Inode_tree of inode_tree inode + | Inode_extender of inode_tree inode_extender + [@@deriving irmin] + + (** Stream proofs represent an explicit traversal of a Merle tree proof. Every + element (a node, a value, or a shallow pointer) met is first "compressed" + by shallowing its children and then recorded in the proof. + + As stream proofs directly encode the recursive construction of the Merkle + root hash is slightly simpler to implement: the verifier simply needs to + hash the compressed elements lazily, without any memory or choice. + + Moreover, the minimality of stream proofs is trivial to check. Once the + computation has consumed the compressed elements required, it is + sufficient to check that no more compressed elements remain in the proof. + + However, as the compressed elements contain all the hashes of their + shallow children, the size of stream proofs is larger (at least double in + size in practice) than tree proofs, which only contains the hash for + intermediate shallow pointers. *) + + (** The type for elements of stream proofs. + + [Value v] is a proof that the next element read in the store is the value + [v]. + + [Node n] is a proof that the next element read in the store is the node + [n]. + + [Inode i] is a proof that the next element read in the store is the inode + [i]. + + [Inode_extender e] is a proof that the next element read in the store is + the node extender [e]. *) + type elt = + | Contents of contents + | Node of (step * kinded_hash) list + | Inode of hash inode + | Inode_extender of hash inode_extender + [@@deriving irmin] + + type stream = elt Seq.t [@@deriving irmin] + (** The type for stream proofs. + + The sequance [e_1 ... e_n] proves that the [e_1], ..., [e_n] are read in + the store in sequence. *) + + type 'a t [@@deriving irmin] + (** The type for proofs of kind ['a] (i.e. [stream] or [proof]). + + A proof [p] proves that the state advanced from [before p] to [after p]. + [state p]'s hash is [before p], and [state p] contains the minimal + information for the computation to reach [after p]. *) + + val v : before:kinded_hash -> after:kinded_hash -> 'a -> 'a t + (** [v ~before ~after p] proves that the state advanced from [before] to + [after]. [p]'s hash is [before], and [p] contains the minimal information + for the computation to reach [after]. *) + + val before : 'a t -> kinded_hash + (** [before t] it the state's hash at the beginning of the computation. *) + + val after : 'a t -> kinded_hash + (** [after t] is the state's hash at the end of the computation. *) + + val state : 'a t -> 'a + (** [proof t] is a subset of the initial state needed to prove that the proven + computation could run without performing any I/O. *) +end + +(** Environment that tracks side effects during the production/consumption of + proofs. + + {1 The Merkle Proof Construction Algorithm} + + This description stands for [Set] proofs and assumes that the large nodes + are represented by the backend as a tree structure (i.e. inodes). + + There are 4 distinct phases when working with Irmin's merkle proofs: + [Produce | Serialise | Deserialise | Consume]. + + {2 [Produce]} + + This phase runs the [f] function provided by the Irmin user. It builds an + [after] tree from a [before] tree that has been setup with an [Env] that + records every backend reads into two hash tables. + + During the next phase (i.e. [Serialise]) the cleared [before] tree will be + traversed from root to stems only following the paths that are referenced in + [Env]. + + In practice [Env] doesn't exactly record the reads, it keeps track of all + the [hash -> backend node] and [hash -> backend contents] mappings that are + directly output of the backend stores through [P.Node.find] and + [P.Contents.find]. This is obviously enough to remember the contents, the + nodes and the inodes tips, but the inner inodes are not directly referenced + in the hash tables. + + The inner inodes are in fact referenced in their inode tip which is itself + referenced in [Env]'s hash tables. Since an inode shares its lazy pointers + with the inodes derived from it, even the inner inodes that are loaded from + the derived tips will be available from the original inode tip. + + {2 [Serialise]} + + In this phase, the [Env] contains everything necessary for the computation + of a Merkle proof from a cleared [before]. The [Env] now affects + [Node.cached_value] and [Contents.cached_value] allowing for the discovery + of the cached closure. + + {2 [Deserialise]} + + In this phase the [Env] is filled by recursively destructing the proof and + filling it before the [Consume] phase. + + {2 [Consume]} + + In this last phase the [Env] is again made accessible through + [Node.cached_pvalue] and [Contents.cached_pvalue], making it possible for + the user to reference by [hash] everything that was contained in the proof. + + {1 Nodes and Portable Nodes} + + While the [Produce] phase must be connected to the backend to records reads, + the [Consume] phase must be disconnected from the backend. + + [Produce] manipulates backend nodes of type [Backend.Node.Val.t] (the ones + enriched with backend keys) + + [Consume] is restricted to manipulating nodes of type + [Backend.Node_portable.t]. + + {1 Hashing of Backend Nodes with Streamed Proofs} + + Hashing a backend node or calling [head] on it may trigger IOs in order to + load inner inodes (this is the case in irmin-pack). + + In various places, [Env] requires calling [head] or [hash_exn] on nodes. + + [Env] must be very careful that these two facts do not lead to chaos during + the recording of IOs' order. + + Two tricks are in place to prevent problems: + + - The [Node.of_proof] functions return nodes that don't require IOs to + produce their hash (i.e. they use caching if necessary). + - The [Node.head] function that is called on a node during + [dehydrate_stream_node] is also called just after [rehydrate_stream_node]. *) +module type Env = sig + type kind = Set | Stream + type mode = Produce | Serialise | Deserialise | Consume + type t [@@deriving irmin] + type hash + type node + type pnode + type contents + type stream + + val is_empty : t -> bool + val empty : unit -> t + val copy : into:t -> t -> unit + + (** {2 Modes} *) + + val set_mode : t -> kind -> mode -> unit + + val with_set_produce : + (t -> start_serialise:(unit -> unit) -> 'a Lwt.t) -> 'a Lwt.t + + val with_set_consume : + (t -> stop_deserialise:(unit -> unit) -> 'a Lwt.t) -> 'a Lwt.t + + val with_stream_produce : + (t -> to_stream:(unit -> stream) -> 'a Lwt.t) -> 'a Lwt.t + + val with_stream_consume : + stream -> (t -> is_empty:(unit -> bool) -> 'a Lwt.t) -> 'a Lwt.t + + (** {2 Interactions With [Tree]} *) + + val add_contents_from_store : t -> hash -> contents -> unit + + val add_node_from_store : t -> hash -> node -> node + (** [add_node_from_store] returns a [node] and not [unit] because [Env] may + take the opportunity to wrap the input node in [Node.Val.with_handler]. *) + + val add_contents_from_proof : t -> hash -> contents -> unit + val add_pnode_from_proof : t -> hash -> pnode -> unit + val find_contents : t -> hash -> contents option + val find_node : t -> hash -> node option + val find_pnode : t -> hash -> pnode option +end + +module type Proof = sig + module type S = S + module type Env = Env + + exception Bad_proof of { context : string } + + type bad_stream_exn = + | Stream_too_long of { context : string; reason : string } + | Stream_too_short of { context : string; reason : string } + | Proof_mismatch of { context : string; reason : string } + + exception Bad_stream of bad_stream_exn + + val bad_proof_exn : string -> 'a + val bad_stream_exn : string -> string -> 'a + val bad_stream_too_long : string -> string -> 'a + val bad_stream_too_short : string -> string -> 'a + + module Make + (C : Type.S) + (H : Hash.S) (P : sig + type step [@@deriving irmin] + end) + (M : Type.S) : sig + include + S + with type contents := C.t + and type hash := H.t + and type step := P.step + and type metadata := M.t + end + + module Env + (B : Backend.S) + (P : S + with type contents := B.Contents.Val.t + and type hash := B.Hash.t + and type step := B.Node.Val.step + and type metadata := B.Node.Val.metadata) : + Env + with type hash := B.Hash.t + and type contents := B.Contents.Val.t + and type node := B.Node.Val.t + and type pnode := B.Node_portable.t + and type stream := P.stream +end diff --git a/vendors/irmin/src/irmin/read_only.ml b/vendors/irmin/src/irmin/read_only.ml new file mode 100644 index 0000000000000000000000000000000000000000..95cc3d33a0528471790a7830ddd0dbab15fd0baf --- /dev/null +++ b/vendors/irmin/src/irmin/read_only.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Read_only_intf diff --git a/vendors/irmin/src/irmin/read_only.mli b/vendors/irmin/src/irmin/read_only.mli new file mode 100644 index 0000000000000000000000000000000000000000..0096f050cf6305db616b3714cd95d983a41ec707 --- /dev/null +++ b/vendors/irmin/src/irmin/read_only.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Read_only_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/read_only_intf.ml b/vendors/irmin/src/irmin/read_only_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..6191822305fd630859aca6f1309a1e73f9b227b3 --- /dev/null +++ b/vendors/irmin/src/irmin/read_only_intf.ml @@ -0,0 +1,57 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +open Store_properties + +module type S = sig + (** {1 Read-only stores} + + Read-only stores are store where it is only possible to read existing + values. *) + + type -'a t + (** The type for stores. The ['a] phantom type carries information about the + store mutability. *) + + type key + (** The type for keys. *) + + type value + (** The type for raw values. *) + + val mem : [> read ] t -> key -> bool Lwt.t + (** [mem t k] is true iff [k] is present in [t]. *) + + val find : [> read ] t -> key -> value option Lwt.t + (** [find t k] is [Some v] if [k] is associated to [v] in [t] and [None] is + [k] is not present in [t]. *) + + include Closeable with type 'a t := 'a t + (** @inline *) +end + +module type Maker = functor (Key : Type.S) (Value : Type.S) -> sig + include S with type key = Key.t and type value = Value.t + + include Of_config with type 'a t := 'a t + (** @inline *) +end + +module type Sigs = sig + module type S = S + module type Maker = Maker +end diff --git a/vendors/irmin/src/irmin/remote.ml b/vendors/irmin/src/irmin/remote.ml new file mode 100644 index 0000000000000000000000000000000000000000..b4d2247985d8826bc24207cbf14ecf82fc6cd62e --- /dev/null +++ b/vendors/irmin/src/irmin/remote.ml @@ -0,0 +1,33 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Remote_intf + +module None (H : Type.S) (R : Type.S) = struct + type t = unit + + let v _ = Lwt.return_unit + + type endpoint = unit + type commit = H.t + type branch = R.t + + let fetch () ?depth:_ _ _br = + Lwt.return (Error (`Msg "fetch operation is not available")) + + let push () ?depth:_ _ _br = + Lwt.return (Error (`Msg "push operation is not available")) +end diff --git a/vendors/irmin/src/irmin/remote.mli b/vendors/irmin/src/irmin/remote.mli new file mode 100644 index 0000000000000000000000000000000000000000..847535554664f1d46284a1716c7e2cbdfbc6cf79 --- /dev/null +++ b/vendors/irmin/src/irmin/remote.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Remote stores. *) + +include Remote_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/remote_intf.ml b/vendors/irmin/src/irmin/remote_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..4237c9a058680b6ecdaf82203ce7c5bcdeece7ea --- /dev/null +++ b/vendors/irmin/src/irmin/remote_intf.ml @@ -0,0 +1,69 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type t = .. + +module type S = sig + (** {1 Remote synchronization} *) + + type t + (** The type for store handles. *) + + type commit + (** The type for store heads. *) + + type branch + (** The type for branch IDs. *) + + type endpoint + (** The type for sync endpoints. *) + + val fetch : + t -> + ?depth:int -> + endpoint -> + branch -> + (commit option, [ `Msg of string ]) result Lwt.t + (** [fetch t uri] fetches the contents of the remote store located at [uri] + into the local store [t]. Return the head of the remote branch with the + same name, which is now in the local store. [No_head] means no such branch + exists. *) + + val push : + t -> + ?depth:int -> + endpoint -> + branch -> + (unit, [ `Msg of string | `Detached_head ]) result Lwt.t + (** [push t uri] pushes the contents of the local store [t] into the remote + store located at [uri]. *) +end + +module type Sigs = sig + module type S = S + + type nonrec t = t = .. + + (** Provides stub implementations of the {!S} that always returns [Error] when + push/pull operations are attempted. *) + module None (H : Type.S) (R : Type.S) : sig + include + S with type commit = H.t and type branch = R.t and type endpoint = unit + + val v : 'a -> t Lwt.t + (** Create a remote store handle. *) + end +end diff --git a/vendors/irmin/src/irmin/reversed_list.ml b/vendors/irmin/src/irmin/reversed_list.ml new file mode 100644 index 0000000000000000000000000000000000000000..18d8523118379c866cad0ef59822ad23c0f68776 --- /dev/null +++ b/vendors/irmin/src/irmin/reversed_list.ml @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type 'a t = 'a list = [] | ( :: ) of 'a * 'a t + +let t a_t = Type.list a_t +let rev = List.rev diff --git a/vendors/irmin/src/irmin/reversed_list.mli b/vendors/irmin/src/irmin/reversed_list.mli new file mode 100644 index 0000000000000000000000000000000000000000..9eb8aeba7caf6196e5087362b462deb7399ef7ba --- /dev/null +++ b/vendors/irmin/src/irmin/reversed_list.mli @@ -0,0 +1,25 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [Reversed_list.t] is constructed the same way as [List.t], but needs to be + reversed before it can be used as a regular list. + + This is helpful when building up a list in reverse in order to force + reversal at the end of the accumulation process. *) + +type 'a t = [] | ( :: ) of 'a * 'a t [@@deriving irmin] + +val rev : 'a t -> 'a list diff --git a/vendors/irmin/src/irmin/schema.ml b/vendors/irmin/src/irmin/schema.ml new file mode 100644 index 0000000000000000000000000000000000000000..6b4c178a570cf5116a3d5d1775dd97136ee8953c --- /dev/null +++ b/vendors/irmin/src/irmin/schema.ml @@ -0,0 +1,73 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2020-2021 Craig Ferguson + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + module Hash : Hash.S + module Branch : Branch.S + module Info : Info.S + module Metadata : Metadata.S + module Path : Path.S + module Contents : Contents.S +end + +module type Extended = sig + include S + + module Node + (Contents_key : Key.S with type hash = Hash.t) + (Node_key : Key.S with type hash = Hash.t) : + Node.Generic_key.S + with type metadata = Metadata.t + and type step = Path.step + and type hash = Hash.t + and type contents_key = Contents_key.t + and type node_key = Node_key.t + + module Commit + (Node_key : Key.S with type hash = Hash.t) + (Commit_key : Key.S with type hash = Hash.t) : + Commit.Generic_key.S + with module Info := Info + and type node_key = Node_key.t + and type commit_key = Commit_key.t +end + +open struct + module Extended_is_a_schema (X : Extended) : S = X +end + +type default_hash = Hash.BLAKE2B.t + +module type KV = + Extended + with type Hash.t = default_hash + and type Branch.t = string + and type Info.t = Info.default + and type Metadata.t = unit + and type Path.step = string + and type Path.t = string list + +module KV (C : Contents.S) : KV with module Contents = C = struct + module Hash = Hash.BLAKE2B + module Info = Info.Default + module Branch = Branch.String + module Path = Path.String_list + module Metadata = Metadata.None + module Contents = C + module Node = Node.Generic_key.Make (Hash) (Path) (Metadata) + module Commit = Commit.Generic_key.Make (Hash) +end diff --git a/vendors/irmin/src/irmin/slice.ml b/vendors/irmin/src/irmin/slice.ml new file mode 100644 index 0000000000000000000000000000000000000000..9f3e7580a8af4da08adb36493b6f63da0941685b --- /dev/null +++ b/vendors/irmin/src/irmin/slice.ml @@ -0,0 +1,58 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Slice_intf + +module Make + (Contents : Contents.Store) + (Node : Node.Store) + (Commit : Commit.Store) = +struct + type contents = Contents.Hash.t * Contents.Val.t [@@deriving irmin] + type node = Node.Hash.t * Node.Val.t [@@deriving irmin] + type commit = Commit.Hash.t * Commit.Val.t [@@deriving irmin] + + type value = [ `Contents of contents | `Node of node | `Commit of commit ] + [@@deriving irmin] + + type t = { + mutable contents : contents list; + mutable nodes : node list; + mutable commits : commit list; + } + [@@deriving irmin] + + let empty () = Lwt.return { contents = []; nodes = []; commits = [] } + + let add t = function + | `Contents c -> + t.contents <- c :: t.contents; + Lwt.return_unit + | `Node n -> + t.nodes <- n :: t.nodes; + Lwt.return_unit + | `Commit c -> + t.commits <- c :: t.commits; + Lwt.return_unit + + let iter t f = + Lwt.join + [ + Lwt_list.iter_p (fun c -> f (`Contents c)) t.contents; + Lwt_list.iter_p (fun n -> f (`Node n)) t.nodes; + Lwt_list.iter_p (fun c -> f (`Commit c)) t.commits; + ] +end diff --git a/vendors/irmin/src/irmin/slice.mli b/vendors/irmin/src/irmin/slice.mli new file mode 100644 index 0000000000000000000000000000000000000000..2d673d627559d50ecdcdaa7909f4441fb2153186 --- /dev/null +++ b/vendors/irmin/src/irmin/slice.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Slice_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/slice_intf.ml b/vendors/irmin/src/irmin/slice_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..fc71483f350d7646a9f3fb3a75133cbf88bbd362 --- /dev/null +++ b/vendors/irmin/src/irmin/slice_intf.ml @@ -0,0 +1,56 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Slices} *) + + type t [@@deriving irmin] + (** The type for slices. *) + + type contents [@@deriving irmin] + (** The type for exported contents. *) + + type node [@@deriving irmin] + (** The type for exported nodes. *) + + type commit [@@deriving irmin] + (** The type for exported commits. *) + + type value = [ `Contents of contents | `Node of node | `Commit of commit ] + [@@deriving irmin] + (** The type for exported values. *) + + val empty : unit -> t Lwt.t + (** Create a new empty slice. *) + + val add : t -> value -> unit Lwt.t + (** [add t v] adds [v] to [t]. *) + + val iter : t -> (value -> unit Lwt.t) -> unit Lwt.t + (** [iter t f] calls [f] on all values of [t]. *) +end + +module type Sigs = sig + module type S = S + (** The signature for slices. *) + + (** Build simple slices. *) + module Make (C : Contents.Store) (N : Node.Store) (H : Commit.Store) : + S + with type contents = C.hash * C.value + and type node = N.hash * N.value + and type commit = H.hash * H.value +end diff --git a/vendors/irmin/src/irmin/store.ml b/vendors/irmin/src/irmin/store.ml new file mode 100644 index 0000000000000000000000000000000000000000..63905aee288fe8297ab8e74c949ad01760f27923 --- /dev/null +++ b/vendors/irmin/src/irmin/store.ml @@ -0,0 +1,1251 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Store_intf +open Merge.Infix + +let src = Logs.Src.create "irmin" ~doc:"Irmin branch-consistent store" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Generic_key = struct + module type S = S_generic_key + module type KV = KV_generic_key + module type Maker = Maker_generic_key + module type KV_maker = KV_maker_generic_key +end + +module Make (B : Backend.S) = struct + module Schema = B.Schema + module Contents_key = B.Contents.Key + module Node_key = B.Node.Key + module Commit_key = B.Commit.Key + module Metadata = B.Node.Metadata + module Typed = Hash.Typed (B.Hash) + module Hash = B.Hash + module Branch_store = B.Branch + module Path = B.Node.Path + module Commits = Commit.History (B.Commit) + module Backend = B + module Info = B.Commit.Info + module T = Tree.Make (B) + + module Contents = struct + include B.Contents.Val + module H = Typed (B.Contents.Val) + + let of_key r k = B.Contents.find (B.Repo.contents_t r) k + + let of_hash r h = + let store = B.Repo.contents_t r in + B.Contents.index store h >>= function + | None -> Lwt.return_none + | Some k -> B.Contents.find store k + + let hash c = H.hash c + end + + module Tree = struct + include T + + let find_key r t = + match key t with + | Some k -> Lwt.return (Some k) + | None -> ( + match hash t with + | `Node h -> ( + B.Node.index (B.Repo.node_t r) h >|= function + | None -> None + | Some k -> Some (`Node k)) + | `Contents (h, m) -> ( + B.Contents.index (B.Repo.contents_t r) h >|= function + | None -> None + | Some k -> Some (`Contents (k, m)))) + + let of_key r k = import r k + + let of_hash r = function + | `Node h -> ( + B.Node.index (B.Repo.node_t r) h >>= function + | None -> Lwt.return_none + | Some k -> of_key r (`Node k)) + | `Contents (h, m) -> ( + B.Contents.index (B.Repo.contents_t r) h >>= function + | None -> Lwt.return_none + | Some k -> of_key r (`Contents (k, m))) + + let shallow r h = import_no_check r h + let kinded_hash = hash + + let hash : ?cache:bool -> t -> hash = + fun ?cache tr -> + match hash ?cache tr with `Node h -> h | `Contents (h, _) -> h + end + + type branch = Branch_store.Key.t [@@deriving irmin ~equal ~pp] + type contents_key = B.Contents.Key.t [@@deriving irmin ~pp ~equal] + type node_key = B.Node.Key.t [@@deriving irmin ~pp ~equal] + type commit_key = B.Commit.Key.t [@@deriving irmin ~pp ~equal] + type repo = B.Repo.t + type commit = { r : repo; key : commit_key; v : B.Commit.value } + type hash = Hash.t [@@deriving irmin ~equal ~pp ~compare] + type node = Tree.node [@@deriving irmin] + type contents = Contents.t [@@deriving irmin ~equal] + type metadata = Metadata.t [@@deriving irmin] + type tree = Tree.t [@@deriving irmin ~pp] + type path = Path.t [@@deriving irmin ~pp] + type step = Path.step [@@deriving irmin] + type info = B.Commit.Info.t [@@deriving irmin] + type Remote.t += E of B.Remote.endpoint + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] [@@deriving irmin] + type ff_error = [ `Rejected | `No_change | lca_error ] + + type write_error = + [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] + + (* The deriver does not work here because of it cannot derive the + [Merge.conflict] inheritance. *) + let write_error_t = + let open Type in + variant "write-error" (fun c m e -> function + | `Conflict x -> c x | `Too_many_retries x -> m x | `Test_was x -> e x) + |~ case1 "conflict" string (fun x -> `Conflict x) + |~ case1 "too-many-retries" int (fun x -> `Too_many_retries x) + |~ case1 "test-got" (option tree_t) (fun x -> `Test_was x) + |> sealv + + (* The deriver does not work here because of it cannot derive the + [lca_error] inheritance. *) + let ff_error_t = + Type.enum "ff-error" + [ + ("max-depth-reached", `Max_depth_reached); + ("too-many-lcas", `Too_many_lcas); + ("no-change", `No_change); + ("rejected", `Rejected); + ] + + let pp_int = Type.pp Type.int + let save_contents b c = B.Contents.add b c + + let save_tree ?(clear = true) r x y (tr : Tree.t) = + match Tree.destruct tr with + | `Contents (c, _) -> + let* c = Tree.Contents.force_exn c in + let+ k = save_contents x c in + `Contents k + | `Node n -> + let+ k = Tree.export ~clear r x y n in + `Node k + + module Contents_keys = Set.Make (struct + type t = Contents_key.t [@@deriving irmin ~compare] + end) + + module Commit = struct + type t = commit + + let t r = + let open Type in + record "commit" (fun key v -> { r; key; v }) + |+ field "key" B.Commit.Key.t (fun t -> t.key) + |+ field "value" B.Commit.Val.t (fun t -> t.v) + |> sealr + + let v r ~info ~parents tree = + B.Repo.batch r @@ fun contents_t node_t commit_t -> + let* node = + match Tree.destruct tree with + | `Node t -> Tree.export r contents_t node_t t + | `Contents _ -> Lwt.fail_invalid_arg "cannot add contents at the root" + in + let v = B.Commit.Val.v ~info ~node ~parents in + let+ key = B.Commit.add commit_t v in + { r; key; v } + + let node t = B.Commit.Val.node t.v + let tree t = Tree.import_no_check t.r (`Node (node t)) + let equal x y = equal_commit_key x.key y.key + let key t = t.key + let hash t = B.Commit.Key.to_hash t.key + let info t = B.Commit.Val.info t.v + let parents t = B.Commit.Val.parents t.v + let pp_hash ppf t = Type.pp Hash.t ppf (hash t) + let pp_key ppf t = Type.pp B.Commit.Key.t ppf t.key + + let of_key r key = + B.Commit.find (B.Repo.commit_t r) key >|= function + | None -> None + | Some v -> Some { r; key; v } + + let of_hash r hash = + B.Commit.index (B.Repo.commit_t r) hash >>= function + | None -> Lwt.return_none + | Some key -> of_key r key + + module H = Typed (B.Commit.Val) + + let to_backend_commit t = t.v + let of_backend_commit r key v = { r; key; v } + + let equal_opt x y = + match (x, y) with + | None, None -> true + | Some x, Some y -> equal x y + | _ -> false + end + + let to_backend_portable_node = Tree.to_backend_portable_node + let to_backend_node = Tree.to_backend_node + let of_backend_node = Tree.of_backend_node + let to_backend_commit = Commit.to_backend_commit + let of_backend_commit = Commit.of_backend_commit + + type head_ref = [ `Branch of branch | `Head of commit option ref ] + + module OCamlGraph = Graph + module Graph = Node.Graph (B.Node) + + module KGraph = + Object_graph.Make (B.Contents.Key) (B.Node.Key) (B.Commit.Key) + (Branch_store.Key) + + type slice = B.Slice.t [@@deriving irmin] + type watch = unit -> unit Lwt.t + + let unwatch w = w () + + module Repo = struct + type t = repo + + let v = B.Repo.v + let config = B.Repo.config + let close = B.Repo.close + let branch_t t = B.Repo.branch_t t + let commit_t t = B.Repo.commit_t t + let node_t t = B.Repo.node_t t + let contents_t t = B.Repo.contents_t t + let branches t = B.Branch.list (branch_t t) + + let heads repo = + let t = branch_t repo in + let* bs = Branch_store.list t in + Lwt_list.fold_left_s + (fun acc r -> + Branch_store.find t r >>= function + | None -> Lwt.return acc + | Some k -> ( + Commit.of_key repo k >|= function + | None -> acc + | Some h -> h :: acc)) + [] bs + + let export ?(full = true) ?depth ?(min = []) ?(max = `Head) t = + [%log.debug + "export depth=%s full=%b min=%d max=%s" + (match depth with None -> "" | Some d -> string_of_int d) + full (List.length min) + (match max with + | `Head -> "heads" + | `Max m -> string_of_int (List.length m))]; + let* max = match max with `Head -> heads t | `Max m -> Lwt.return m in + let* slice = B.Slice.empty () in + let max = List.map (fun x -> `Commit x.key) max in + let min = List.map (fun x -> `Commit x.key) min in + let pred = function + | `Commit k -> + let+ parents = Commits.parents (commit_t t) k in + List.map (fun x -> `Commit x) parents + | _ -> Lwt.return_nil + in + let* g = KGraph.closure ?depth ~pred ~min ~max () in + let keys = + List.fold_left + (fun acc -> function `Commit c -> c :: acc | _ -> acc) + [] (KGraph.vertex g) + in + let root_nodes = ref [] in + let* () = + Lwt_list.iter_p + (fun k -> + B.Commit.find (commit_t t) k >>= function + | None -> Lwt.return_unit + | Some c -> + root_nodes := B.Commit.Val.node c :: !root_nodes; + B.Slice.add slice (`Commit (Commit_key.to_hash k, c))) + keys + in + if not full then Lwt.return slice + else + (* XXX: we can compute a [min] if needed *) + let* nodes = Graph.closure (node_t t) ~min:[] ~max:!root_nodes in + let contents = ref Contents_keys.empty in + let* () = + Lwt_list.iter_p + (fun k -> + B.Node.find (node_t t) k >>= function + | None -> Lwt.return_unit + | Some v -> + List.iter + (function + | _, `Contents (c, _) -> + contents := Contents_keys.add c !contents + | _ -> ()) + (B.Node.Val.list v); + B.Slice.add slice (`Node (Node_key.to_hash k, v))) + nodes + in + let+ () = + Lwt_list.iter_p + (fun k -> + B.Contents.find (contents_t t) k >>= function + | None -> Lwt.return_unit + | Some m -> + B.Slice.add slice (`Contents (Contents_key.to_hash k, m))) + (Contents_keys.elements !contents) + in + slice + + exception Import_error of string + + let import_error fmt = Fmt.kstr (fun x -> Lwt.fail (Import_error x)) fmt + + let import t s = + let aux name key_to_hash add (h, v) = + let* k' = add v in + let h' = key_to_hash k' in + if not (equal_hash h h') then + import_error "%s import error: expected %a, got %a" name pp_hash h + pp_hash h' + else Lwt.return_unit + in + let contents = ref [] in + let nodes = ref [] in + let commits = ref [] in + let* () = + B.Slice.iter s (function + | `Contents c -> + contents := c :: !contents; + Lwt.return_unit + | `Node n -> + nodes := n :: !nodes; + Lwt.return_unit + | `Commit c -> + commits := c :: !commits; + Lwt.return_unit) + in + B.Repo.batch t @@ fun contents_t node_t commit_t -> + Lwt.catch + (fun () -> + let* () = + Lwt_list.iter_p + (aux "Contents" B.Contents.Key.to_hash + (B.Contents.add contents_t)) + !contents + in + Lwt_list.iter_p + (aux "Node" B.Node.Key.to_hash (B.Node.add node_t)) + !nodes + >>= fun () -> + let+ () = + Lwt_list.iter_p + (aux "Commit" B.Commit.Key.to_hash (B.Commit.add commit_t)) + !commits + in + Ok ()) + (function + | Import_error e -> Lwt.return (Error (`Msg e)) + | e -> Fmt.kstr Lwt.fail_invalid_arg "impot error: %a" Fmt.exn e) + + type elt = + [ `Commit of commit_key + | `Node of node_key + | `Contents of contents_key + | `Branch of B.Branch.Key.t ] + [@@deriving irmin] + + let ignore_lwt _ = Lwt.return_unit + let return_false _ = Lwt.return false + let default_pred_contents _ _ = Lwt.return [] + + let default_pred_node t k = + B.Node.find (node_t t) k >|= function + | None -> [] + | Some v -> + List.rev_map + (function + | _, `Node n -> `Node n | _, `Contents (c, _) -> `Contents c) + (B.Node.Val.list v) + + let default_pred_commit t c = + B.Commit.find (commit_t t) c >|= function + | None -> + [%log.debug "%a: not found" pp_commit_key c]; + [] + | Some c -> + let node = B.Commit.Val.node c in + let parents = B.Commit.Val.parents c in + [ `Node node ] @ List.map (fun k -> `Commit k) parents + + let default_pred_branch t b = + B.Branch.find (branch_t t) b >|= function + | None -> + [%log.debug "%a: not found" pp_branch b]; + [] + | Some b -> [ `Commit b ] + + let iter ?cache_size ~min ~max ?edge ?(branch = ignore_lwt) + ?(commit = ignore_lwt) ?(node = ignore_lwt) ?(contents = ignore_lwt) + ?(skip_branch = return_false) ?(skip_commit = return_false) + ?(skip_node = return_false) ?(skip_contents = return_false) + ?(pred_branch = default_pred_branch) + ?(pred_commit = default_pred_commit) ?(pred_node = default_pred_node) + ?(pred_contents = default_pred_contents) ?(rev = true) t = + let node = function + | `Commit x -> commit x + | `Node x -> node x + | `Contents x -> contents x + | `Branch x -> branch x + in + let skip = function + | `Commit x -> skip_commit x + | `Node x -> skip_node x + | `Contents x -> skip_contents x + | `Branch x -> skip_branch x + in + let pred = function + | `Commit x -> pred_commit t x + | `Node x -> pred_node t x + | `Contents x -> pred_contents t x + | `Branch x -> pred_branch t x + in + KGraph.iter ?cache_size ~pred ~min ~max ~node ?edge ~skip ~rev () + + let breadth_first_traversal ?cache_size ~max ?(branch = ignore_lwt) + ?(commit = ignore_lwt) ?(node = ignore_lwt) ?(contents = ignore_lwt) + ?(pred_branch = default_pred_branch) + ?(pred_commit = default_pred_commit) ?(pred_node = default_pred_node) + ?(pred_contents = default_pred_contents) t = + let node = function + | `Commit x -> commit x + | `Node x -> node x + | `Contents x -> contents x + | `Branch x -> branch x + in + let pred = function + | `Commit x -> pred_commit t x + | `Node x -> pred_node t x + | `Contents x -> pred_contents t x + | `Branch x -> pred_branch t x + in + KGraph.breadth_first_traversal ?cache_size ~pred ~max ~node () + end + + type t = { + repo : Repo.t; + head_ref : head_ref; + mutable tree : (commit * tree) option; + (* cache for the store tree *) + lock : Lwt_mutex.t; + } + + let repo t = t.repo + let branch_store t = Repo.branch_t t.repo + let commit_store t = Repo.commit_t t.repo + + let status t = + match t.head_ref with + | `Branch b -> `Branch b + | `Head h -> ( match !h with None -> `Empty | Some c -> `Commit c) + + let head_ref t = + match t.head_ref with + | `Branch t -> `Branch t + | `Head h -> ( match !h with None -> `Empty | Some h -> `Head h) + + let branch t = + match head_ref t with + | `Branch t -> Lwt.return_some t + | `Empty | `Head _ -> Lwt.return_none + + let err_no_head s = Fmt.kstr Lwt.fail_invalid_arg "Irmin.%s: no head" s + + let retry_merge name fn = + let rec aux i = + fn () >>= function + | Error _ as c -> Lwt.return c + | Ok true -> Merge.ok () + | Ok false -> + [%log.debug "Irmin.%s: conflict, retrying (%d)." name i]; + aux (i + 1) + in + aux 1 + + let of_ref repo head_ref = + let lock = Lwt_mutex.create () in + Lwt.return { lock; head_ref; repo; tree = None } + + let err_invalid_branch t = + let err = Fmt.str "%a is not a valid branch name." pp_branch t in + Lwt.fail (Invalid_argument err) + + let of_branch repo key = + if Branch_store.Key.is_valid key then of_ref repo (`Branch key) + else err_invalid_branch key + + let main repo = of_branch repo Branch_store.Key.main + let master = main + let empty repo = of_ref repo (`Head (ref None)) + let of_commit c = of_ref c.r (`Head (ref (Some c))) + + let skip_key key = + [%log.debug "[watch-key] key %a has not changed" pp_path key]; + Lwt.return_unit + + let changed_key key old_t new_t = + [%log.debug + fun l -> + let pp = Fmt.option ~none:(Fmt.any "") pp_hash in + let old_h = Option.map Tree.hash old_t in + let new_h = Option.map Tree.hash new_t in + l "[watch-key] key %a has changed: %a -> %a" pp_path key pp old_h pp + new_h] + + let with_tree ~key x f = + x >>= function + | None -> skip_key key + | Some x -> + changed_key key None None; + f x + + let lift_tree_diff ~key tree fn = function + | `Removed x -> + with_tree ~key (tree x) @@ fun v -> + changed_key key (Some v) None; + fn @@ `Removed (x, v) + | `Added x -> + with_tree ~key (tree x) @@ fun v -> + changed_key key None (Some v); + fn @@ `Added (x, v) + | `Updated (x, y) -> ( + assert (not (Commit.equal x y)); + let* vx = tree x in + let* vy = tree y in + match (vx, vy) with + | None, None -> skip_key key + | None, Some vy -> + changed_key key None (Some vy); + fn @@ `Added (y, vy) + | Some vx, None -> + changed_key key (Some vx) None; + fn @@ `Removed (x, vx) + | Some vx, Some vy -> + if Tree.equal vx vy then skip_key key + else ( + changed_key key (Some vx) (Some vy); + fn @@ `Updated ((x, vx), (y, vy)))) + + let head t = + let h = + match head_ref t with + | `Head key -> Lwt.return_some key + | `Empty -> Lwt.return_none + | `Branch name -> ( + Branch_store.find (branch_store t) name >>= function + | None -> Lwt.return_none + | Some k -> Commit.of_key t.repo k) + in + let+ h = h in + [%log.debug "Head.find -> %a" Fmt.(option Commit.pp_key) h]; + h + + let tree_and_head t = + head t >|= function + | None -> None + | Some h -> ( + match t.tree with + | Some (o, t) when Commit.equal o h -> Some (o, t) + | _ -> + t.tree <- None; + + (* the tree cache needs to be invalidated *) + let tree = Tree.import_no_check (repo t) (`Node (Commit.node h)) in + t.tree <- Some (h, tree); + Some (h, tree)) + + let tree t = + tree_and_head t >|= function + | None -> Tree.empty () + | Some (_, tree) -> (tree :> tree) + + let lift_head_diff repo fn = function + | `Removed x -> ( + Commit.of_key repo x >>= function + | None -> Lwt.return_unit + | Some x -> fn (`Removed x)) + | `Updated (x, y) -> ( + let* x = Commit.of_key repo x in + let* y = Commit.of_key repo y in + match (x, y) with + | None, None -> Lwt.return_unit + | Some x, None -> fn (`Removed x) + | None, Some y -> fn (`Added y) + | Some x, Some y -> fn (`Updated (x, y))) + | `Added x -> ( + Commit.of_key repo x >>= function + | None -> Lwt.return_unit + | Some x -> fn (`Added x)) + + let watch t ?init fn = + branch t >>= function + | None -> failwith "watch a detached head: TODO" + | Some name0 -> + let init = + match init with + | None -> None + | Some head0 -> Some [ (name0, head0.key) ] + in + let+ key = + Branch_store.watch (branch_store t) ?init (fun name head -> + if equal_branch name0 name then lift_head_diff t.repo fn head + else Lwt.return_unit) + in + fun () -> Branch_store.unwatch (branch_store t) key + + let watch_key t key ?init fn = + [%log.debug "watch-key %a" pp_path key]; + let tree c = Tree.find_tree (Commit.tree c) key in + watch t ?init (lift_tree_diff ~key tree fn) + + module Head = struct + let list = Repo.heads + let find = head + + let get t = + find t >>= function None -> err_no_head "head" | Some k -> Lwt.return k + + let set t c = + match t.head_ref with + | `Head h -> + h := Some c; + Lwt.return_unit + | `Branch name -> Branch_store.set (branch_store t) name c.key + + let test_and_set_unsafe t ~test ~set = + match t.head_ref with + | `Head head -> + (* [head] is protected by [t.lock]. *) + if Commit.equal_opt !head test then ( + head := set; + Lwt.return_true) + else Lwt.return_false + | `Branch name -> + let h = function None -> None | Some c -> Some c.key in + Branch_store.test_and_set (branch_store t) name ~test:(h test) + ~set:(h set) + + let test_and_set t ~test ~set = + Lwt_mutex.with_lock t.lock (fun () -> test_and_set_unsafe t ~test ~set) + + let fast_forward t ?max_depth ?n new_head = + let return x = if x then Ok () else Error (`Rejected :> ff_error) in + find t >>= function + | None -> test_and_set t ~test:None ~set:(Some new_head) >|= return + | Some old_head -> ( + [%log.debug + "fast-forward-head old=%a new=%a" Commit.pp_hash old_head + Commit.pp_hash new_head]; + if Commit.equal new_head old_head then + (* we only update if there is a change *) + Lwt.return (Error `No_change) + else + Commits.lcas (commit_store t) ?max_depth ?n new_head.key + old_head.key + >>= function + | Ok [ x ] when equal_commit_key x old_head.key -> + (* we only update if new_head > old_head *) + test_and_set t ~test:(Some old_head) ~set:(Some new_head) + >|= return + | Ok _ -> Lwt.return (Error `Rejected) + | Error e -> Lwt.return (Error (e :> ff_error))) + + (* Merge two commits: + - Search for common ancestors + - Perform recursive 3-way merges *) + let three_way_merge t ?max_depth ?n ~info c1 c2 = + B.Repo.batch (repo t) @@ fun _ _ commit_t -> + Commits.three_way_merge commit_t ?max_depth ?n ~info c1.key c2.key + + (* FIXME: we might want to keep the new commit in case of conflict, + and use it as a base for the next merge. *) + let merge ~into:t ~info ?max_depth ?n c1 = + [%log.debug "merge_head"]; + let aux () = + let* head = head t in + match head with + | None -> test_and_set_unsafe t ~test:head ~set:(Some c1) >>= Merge.ok + | Some c2 -> + three_way_merge t ~info ?max_depth ?n c1 c2 >>=* fun c3 -> + let* c3 = Commit.of_key t.repo c3 in + test_and_set_unsafe t ~test:head ~set:c3 >>= Merge.ok + in + Lwt_mutex.with_lock t.lock (fun () -> retry_merge "merge_head" aux) + end + + (* Retry an operation until the optimistic lock is happy. Ensure + that the operation is done at least once. *) + let retry ~retries fn = + let done_once = ref false in + let rec aux i = + if !done_once && i > retries then + Lwt.return (Error (`Too_many_retries retries)) + else + fn () >>= function + | Ok true -> Lwt.return (Ok ()) + | Error e -> Lwt.return (Error e) + | Ok false -> + done_once := true; + aux (i + 1) + in + aux 0 + + let root_tree = function + | `Node _ as n -> Tree.v n + | `Contents _ -> assert false + + let add_commit t old_head ((c, _) as tree) = + match t.head_ref with + | `Head head -> + Lwt_mutex.with_lock t.lock (fun () -> + if not (Commit.equal_opt old_head !head) then Lwt.return_false + else ( + (* [head] is protected by [t.lock] *) + head := Some c; + t.tree <- Some tree; + Lwt.return_true)) + | `Branch name -> + (* concurrent handlers and/or process can modify the + branch. Need to check that we are still working on the same + head. *) + let test = match old_head with None -> None | Some c -> Some c.key in + let set = Some c.key in + let+ r = Branch_store.test_and_set (branch_store t) name ~test ~set in + if r then t.tree <- Some tree; + r + + let pp_write_error ppf = function + | `Conflict e -> Fmt.pf ppf "Got a conflict: %s" e + | `Too_many_retries i -> + Fmt.pf ppf + "Failure after %d attempts to retry the operation: Too many attempts." + i + | `Test_was t -> + Fmt.pf ppf "Test-and-set failed: got %a when reading the store" + Fmt.(Dump.option pp_tree) + t + + let write_error e : ('a, write_error) result Lwt.t = Lwt.return (Error e) + let err_test v = write_error (`Test_was v) + + type snapshot = { + head : commit option; + root : tree; + tree : tree option; + (* the subtree used by the transaction *) + parents : commit list; + } + + let snapshot t key = + tree_and_head t >>= function + | None -> + Lwt.return + { head = None; root = Tree.empty (); tree = None; parents = [] } + | Some (c, root) -> + let root = (root :> tree) in + let+ tree = Tree.find_tree root key in + { head = Some c; root; tree; parents = [ c ] } + + let same_tree x y = + match (x, y) with + | None, None -> true + | None, _ | _, None -> false + | Some x, Some y -> Tree.equal x y + + (* Update the store with a new commit. Ensure the no commit becomes orphan + in the process. *) + let update ?(allow_empty = false) ~info ?parents t key merge_tree f = + let* s = snapshot t key in + (* this might take a very long time *) + let* new_tree = f s.tree in + (* if no change and [allow_empty = true] then, do nothing *) + if same_tree s.tree new_tree && (not allow_empty) && s.head <> None then + Lwt.return (Ok true) + else + merge_tree s.root key ~current_tree:s.tree ~new_tree >>= function + | Error e -> Lwt.return (Error e) + | Ok root -> + let info = info () in + let parents = match parents with None -> s.parents | Some p -> p in + let parents = List.map Commit.key parents in + let* c = Commit.v (repo t) ~info ~parents root in + let* r = add_commit t s.head (c, root_tree (Tree.destruct root)) in + Lwt.return (Ok r) + + let ok x = Ok x + + let fail name = function + | Ok x -> Lwt.return x + | Error e -> Fmt.kstr Lwt.fail_with "%s: %a" name pp_write_error e + + let set_tree_once root key ~current_tree:_ ~new_tree = + match new_tree with + | None -> Tree.remove root key >|= ok + | Some tree -> Tree.add_tree root key tree >|= ok + + let set_tree ?(retries = 13) ?allow_empty ?parents ~info t k v = + [%log.debug "set %a" pp_path k]; + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> + Lwt.return_some v + + let set_tree_exn ?retries ?allow_empty ?parents ~info t k v = + set_tree ?retries ?allow_empty ?parents ~info t k v >>= fail "set_exn" + + let remove ?(retries = 13) ?allow_empty ?parents ~info t k = + [%log.debug "debug %a" pp_path k]; + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> + Lwt.return_none + + let remove_exn ?retries ?allow_empty ?parents ~info t k = + remove ?retries ?allow_empty ?parents ~info t k >>= fail "remove_exn" + + let set ?retries ?allow_empty ?parents ~info t k v = + let v = Tree.of_contents v in + set_tree t k ?retries ?allow_empty ?parents ~info v + + let set_exn ?retries ?allow_empty ?parents ~info t k v = + set t k ?retries ?allow_empty ?parents ~info v >>= fail "set_exn" + + let test_and_set_tree_once ~test root key ~current_tree ~new_tree = + match (test, current_tree) with + | None, None -> set_tree_once root key ~new_tree ~current_tree + | None, _ | _, None -> err_test current_tree + | Some test, Some v -> + if Tree.equal test v then set_tree_once root key ~new_tree ~current_tree + else err_test current_tree + + let test_and_set_tree ?(retries = 13) ?allow_empty ?parents ~info t k ~test + ~set = + [%log.debug "test-and-set %a" pp_path k]; + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info (test_and_set_tree_once ~test) + @@ fun _tree -> Lwt.return set + + let test_and_set_tree_exn ?retries ?allow_empty ?parents ~info t k ~test ~set + = + test_and_set_tree ?retries ?allow_empty ?parents ~info t k ~test ~set + >>= fail "test_and_set_tree_exn" + + let test_and_set ?retries ?allow_empty ?parents ~info t k ~test ~set = + let test = Option.map Tree.of_contents test in + let set = Option.map Tree.of_contents set in + test_and_set_tree ?retries ?allow_empty ?parents ~info t k ~test ~set + + let test_and_set_exn ?retries ?allow_empty ?parents ~info t k ~test ~set = + test_and_set ?retries ?allow_empty ?parents ~info t k ~test ~set + >>= fail "test_and_set_exn" + + let merge_once ~old root key ~current_tree ~new_tree = + let old = Merge.promise old in + Merge.f (Merge.option Tree.merge) ~old current_tree new_tree >>= function + | Ok tr -> set_tree_once root key ~new_tree:tr ~current_tree + | Error e -> write_error (e :> write_error) + + let merge_tree ?(retries = 13) ?allow_empty ?parents ~info ~old t k tree = + [%log.debug "merge %a" pp_path k]; + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info (merge_once ~old) @@ fun _tree -> + Lwt.return tree + + let merge_tree_exn ?retries ?allow_empty ?parents ~info ~old t k tree = + merge_tree ?retries ?allow_empty ?parents ~info ~old t k tree + >>= fail "merge_tree_exn" + + let merge ?retries ?allow_empty ?parents ~info ~old t k v = + let old = Option.map Tree.of_contents old in + let v = Option.map Tree.of_contents v in + merge_tree ?retries ?allow_empty ?parents ~info ~old t k v + + let merge_exn ?retries ?allow_empty ?parents ~info ~old t k v = + merge ?retries ?allow_empty ?parents ~info ~old t k v >>= fail "merge_exn" + + let mem t k = tree t >>= fun tree -> Tree.mem tree k + let mem_tree t k = tree t >>= fun tree -> Tree.mem_tree tree k + let find_all t k = tree t >>= fun tree -> Tree.find_all tree k + let find t k = tree t >>= fun tree -> Tree.find tree k + let get t k = tree t >>= fun tree -> Tree.get tree k + let find_tree t k = tree t >>= fun tree -> Tree.find_tree tree k + let get_tree t k = tree t >>= fun tree -> Tree.get_tree tree k + + let key t k = + find_tree t k >|= function + | None -> None + | Some tree -> ( + match Tree.key tree with + | Some (`Contents (key, _)) -> Some (`Contents key) + | Some (`Node key) -> Some (`Node key) + | None -> None) + + let hash t k = + find_tree t k >|= function + | None -> None + | Some tree -> Some (Tree.hash tree) + + let get_all t k = tree t >>= fun tree -> Tree.get_all tree k + let list t k = tree t >>= fun tree -> Tree.list tree k + let kind t k = tree t >>= fun tree -> Tree.kind tree k + + let with_tree ?(retries = 13) ?allow_empty ?parents + ?(strategy = `Test_and_set) ~info t key f = + let done_once = ref false in + let rec aux n old_tree = + [%log.debug "with_tree %a (%d/%d)" pp_path key n retries]; + if !done_once && n > retries then write_error (`Too_many_retries retries) + else + let* new_tree = f old_tree in + match (strategy, new_tree) with + | `Set, Some tree -> + set_tree t key ~retries ?allow_empty ?parents tree ~info + | `Set, None -> remove t key ~retries ?allow_empty ~info ?parents + | `Test_and_set, _ -> ( + test_and_set_tree t key ~retries ?allow_empty ?parents ~info + ~test:old_tree ~set:new_tree + >>= function + | Error (`Test_was tr) when retries > 0 && n <= retries -> + done_once := true; + aux (n + 1) tr + | e -> Lwt.return e) + | `Merge, _ -> ( + merge_tree ~old:old_tree ~retries ?allow_empty ?parents ~info t key + new_tree + >>= function + | Ok _ as x -> Lwt.return x + | Error (`Conflict _) when retries > 0 && n <= retries -> + done_once := true; + + (* use the store's current tree as the new 'old store' *) + let* old_tree = + tree_and_head t >>= function + | None -> Lwt.return_none + | Some (_, tr) -> Tree.find_tree (tr :> tree) key + in + aux (n + 1) old_tree + | Error e -> write_error e) + in + let* old_tree = find_tree t key in + aux 0 old_tree + + let with_tree_exn ?retries ?allow_empty ?parents ?strategy ~info f t key = + with_tree ?retries ?allow_empty ?strategy ?parents ~info f t key + >>= fail "with_tree_exn" + + let clone ~src ~dst = + let* () = + Head.find src >>= function + | None -> Branch_store.remove (branch_store src) dst + | Some h -> Branch_store.set (branch_store src) dst h.key + in + of_branch (repo src) dst + + let return_lcas r = function + | Error _ as e -> Lwt.return e + | Ok commits -> + Lwt_list.filter_map_p (Commit.of_key r) commits >|= Result.ok + + let lcas ?max_depth ?n t1 t2 = + let* h1 = Head.get t1 in + let* h2 = Head.get t2 in + Commits.lcas (commit_store t1) ?max_depth ?n h1.key h2.key + >>= return_lcas t1.repo + + let lcas_with_commit t ?max_depth ?n c = + let* h = Head.get t in + Commits.lcas (commit_store t) ?max_depth ?n h.key c.key + >>= return_lcas t.repo + + let lcas_with_branch t ?max_depth ?n b = + let* h = Head.get t in + let* head = Head.get { t with head_ref = `Branch b } in + Commits.lcas (commit_store t) ?max_depth ?n h.key head.key + >>= return_lcas t.repo + + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Merge.conflict) result Lwt.t + + let merge_with_branch t ~info ?max_depth ?n other = + [%log.debug "merge_with_branch %a" pp_branch other]; + Branch_store.find (branch_store t) other >>= function + | None -> + Fmt.kstr Lwt.fail_invalid_arg + "merge_with_branch: %a is not a valid branch ID" pp_branch other + | Some c -> ( + Commit.of_key t.repo c >>= function + | None -> Lwt.fail_invalid_arg "invalid commit" + | Some c -> Head.merge ~into:t ~info ?max_depth ?n c) + + let merge_with_commit t ~info ?max_depth ?n other = + Head.merge ~into:t ~info ?max_depth ?n other + + let merge_into ~into ~info ?max_depth ?n t = + [%log.debug "merge"]; + match head_ref t with + | `Branch name -> merge_with_branch into ~info ?max_depth ?n name + | `Head h -> merge_with_commit into ~info ?max_depth ?n h + | `Empty -> Merge.ok () + + module History = OCamlGraph.Persistent.Digraph.ConcreteBidirectional (struct + type t = commit + + let hash h = B.Hash.short_hash (Commit.hash h) + let compare_key = Type.(unstage (compare B.Commit.Key.t)) + let compare x y = compare_key x.key y.key + let equal x y = equal_commit_key x.key y.key + end) + + module Gmap = struct + module Src = KGraph + + module Dst = struct + include History + + let empty () = empty + end + + let filter_map f g = + let t = Dst.empty () in + if Src.nb_vertex g = 1 then + match Src.vertex g with + | [ v ] -> ( + f v >|= function Some v -> Dst.add_vertex t v | None -> t) + | _ -> assert false + else + Src.fold_edges + (fun x y t -> + let* t = t in + let* x = f x in + let+ y = f y in + match (x, y) with + | Some x, Some y -> + let t = Dst.add_vertex t x in + let t = Dst.add_vertex t y in + Dst.add_edge t x y + | _ -> t) + g (Lwt.return t) + end + + let history ?depth ?(min = []) ?(max = []) t = + [%log.debug "history"]; + let pred = function + | `Commit k -> + Commits.parents (commit_store t) k + >>= Lwt_list.filter_map_p (Commit.of_key t.repo) + >|= fun parents -> List.map (fun x -> `Commit x.key) parents + | _ -> Lwt.return_nil + in + let* max = Head.find t >|= function Some h -> [ h ] | None -> max in + let max = List.map (fun k -> `Commit k.key) max in + let min = List.map (fun k -> `Commit k.key) min in + let* g = Gmap.Src.closure ?depth ~min ~max ~pred () in + Gmap.filter_map + (function `Commit k -> Commit.of_key t.repo k | _ -> Lwt.return_none) + g + + module Heap = Binary_heap.Make (struct + type t = commit * int + + let compare c1 c2 = + (* [bheap] operates on miminums, we need to invert the comparison. *) + -Int64.compare + (Info.date (Commit.info (fst c1))) + (Info.date (Commit.info (fst c2))) + end) + + let last_modified ?depth ?(n = 1) t key = + [%log.debug + "last_modified depth=%a n=%d key=%a" + Fmt.(Dump.option pp_int) + depth n pp_path key]; + let repo = repo t in + let* commit = Head.get t in + let heap = Heap.create ~dummy:(commit, 0) 0 in + let () = Heap.add heap (commit, 0) in + let rec search acc = + if Heap.is_empty heap || List.length acc = n then Lwt.return acc + else + let current, current_depth = Heap.pop_minimum heap in + let parents = Commit.parents current in + let tree = Commit.tree current in + let* current_value = Tree.find tree key in + if List.length parents = 0 then + if current_value <> None then Lwt.return (current :: acc) + else Lwt.return acc + else + let max_depth = + match depth with + | Some depth -> current_depth >= depth + | None -> false + in + let* found = + Lwt_list.for_all_p + (fun hash -> + Commit.of_key repo hash >>= function + | Some commit -> ( + let () = + if not max_depth then + Heap.add heap (commit, current_depth + 1) + in + let tree = Commit.tree commit in + let+ e = Tree.find tree key in + match (e, current_value) with + | Some x, Some y -> not (equal_contents x y) + | Some _, None -> true + | None, Some _ -> true + | _, _ -> false) + | None -> Lwt.return_false) + parents + in + if found then search (current :: acc) else search acc + in + search [] + + module Branch = struct + include B.Branch.Key + + let mem t = B.Branch.mem (B.Repo.branch_t t) + + let find t br = + B.Branch.find (Repo.branch_t t) br >>= function + | None -> Lwt.return_none + | Some h -> Commit.of_key t h + + let set t br h = B.Branch.set (B.Repo.branch_t t) br h.key + let remove t = B.Branch.remove (B.Repo.branch_t t) + let list = Repo.branches + + let watch t k ?init f = + let init = match init with None -> None | Some h -> Some h.key in + let+ w = + B.Branch.watch_key (Repo.branch_t t) k ?init (lift_head_diff t f) + in + fun () -> Branch_store.unwatch (Repo.branch_t t) w + + let watch_all t ?init f = + let init = + match init with + | None -> None + | Some i -> Some (List.map (fun (k, v) -> (k, v.key)) i) + in + let f k v = lift_head_diff t (f k) v in + let+ w = B.Branch.watch (Repo.branch_t t) ?init f in + fun () -> Branch_store.unwatch (Repo.branch_t t) w + + let err_not_found k = + Fmt.kstr invalid_arg "Branch.get: %a not found" pp_branch k + + let get t k = + find t k >>= function None -> err_not_found k | Some v -> Lwt.return v + end + + module Status = struct + type t = [ `Empty | `Branch of branch | `Commit of commit ] + + let t r = + let open Type in + variant "status" (fun empty branch commit -> function + | `Empty -> empty | `Branch b -> branch b | `Commit c -> commit c) + |~ case0 "empty" `Empty + |~ case1 "branch" Branch.t (fun b -> `Branch b) + |~ case1 "commit" (Commit.t r) (fun c -> `Commit c) + |> sealv + + let pp ppf = function + | `Empty -> Fmt.string ppf "empty" + | `Branch b -> pp_branch ppf b + | `Commit c -> pp_hash ppf (Commit_key.to_hash c.key) + end + + let commit_t = Commit.t +end + +module Json_tree (Store : S with type Schema.Contents.t = Contents.json) = +struct + include Contents.Json_value + + type json = Contents.json + + let to_concrete_tree j : Store.Tree.concrete = + let rec obj j acc = + match j with + | [] -> `Tree acc + | (k, v) :: l -> ( + match Type.of_string Store.Path.step_t k with + | Ok key -> obj l ((key, node v []) :: acc) + | _ -> obj l acc) + and node j acc = + match j with + | `O j -> obj j acc + | _ -> `Contents (j, Store.Metadata.default) + in + node j [] + + let of_concrete_tree c : json = + let step = Type.to_string Store.Path.step_t in + let rec tree t acc = + match t with + | [] -> `O acc + | (k, v) :: l -> tree l ((step k, contents v []) :: acc) + and contents t acc = + match t with `Contents (c, _) -> c | `Tree c -> tree c acc + in + contents c [] + + let set_tree (tree : Store.tree) key j : Store.tree Lwt.t = + let c = to_concrete_tree j in + let c = Store.Tree.of_concrete c in + Store.Tree.add_tree tree key c + + let get_tree (tree : Store.tree) key = + let* t = Store.Tree.get_tree tree key in + let+ c = Store.Tree.to_concrete t in + of_concrete_tree c + + let set t key j ~info = + set_tree (Store.Tree.empty ()) Store.Path.empty j >>= function + | tree -> Store.set_tree_exn ~info t key tree + + let get t key = + let* tree = Store.get_tree t key in + get_tree tree Store.Path.empty +end + +type Remote.t += + | Store : (module Generic_key.S with type t = 'a) * 'a -> Remote.t diff --git a/vendors/irmin/src/irmin/store.mli b/vendors/irmin/src/irmin/store.mli new file mode 100644 index 0000000000000000000000000000000000000000..a79f53b71208fb4fed308236f20a5df0cd7ed7cb --- /dev/null +++ b/vendors/irmin/src/irmin/store.mli @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Branch-consistent stores: read-write store with support fork/merge + operations. *) + +include Store_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/store_intf.ml b/vendors/irmin/src/irmin/store_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..b25d99169a7351ddf6953d51306e3147a1f690ca --- /dev/null +++ b/vendors/irmin/src/irmin/store_intf.ml @@ -0,0 +1,1172 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Store_properties + +module type S_generic_key = sig + (** {1 Irmin stores} + + Irmin stores are tree-like read-write stores with extended capabilities. + They allow an application (or a collection of applications) to work with + multiple local states, which can be forked and merged programmatically, + without having to rely on a global state. In a way very similar to version + control systems, Irmin local states are called {i branches}. + + There are two kinds of store in Irmin: the ones based on {{!of_branch} + persistent} named branches and the ones based {{!of_commit} temporary} + detached heads. These exist relative to a local, larger (and shared) + store, and have some (shared) contents. This is exactly the same as usual + version control systems, that the informed user can see as an implicit + purely functional data-structure. *) + + module Schema : Schema.S + + type repo + (** The type for Irmin repositories. *) + + type t + (** The type for Irmin stores. *) + + type step = Schema.Path.step [@@deriving irmin] + (** The type for {!type-key} steps. *) + + type path = Schema.Path.t [@@deriving irmin] + (** The type for store keys. A key is a sequence of {!step}s. *) + + type metadata = Schema.Metadata.t [@@deriving irmin] + (** The type for store metadata. *) + + type contents = Schema.Contents.t [@@deriving irmin] + (** The type for store contents. *) + + type node [@@deriving irmin] + (** The type for store nodes. *) + + type tree [@@deriving irmin] + (** The type for store trees. *) + + type hash = Schema.Hash.t [@@deriving irmin] + (** The type for object hashes. *) + + type commit + (** Type for [`Commit] identifiers. Similar to Git's commit SHA1s. *) + + val commit_t : repo -> commit Type.t + (** [commit_t r] is the value type for {!commit}. *) + + type branch = Schema.Branch.t [@@deriving irmin] + (** Type for persistent branch names. Branches usually share a common global + namespace and it's the user's responsibility to avoid name clashes. *) + + type slice [@@deriving irmin] + (** Type for store slices. *) + + type info = Schema.Info.t [@@deriving irmin] + (** The type for commit info. *) + + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] [@@deriving irmin] + (** The type for errors associated with functions computing least common + ancestors *) + + type ff_error = [ `No_change | `Rejected | lca_error ] [@@deriving irmin] + (** The type for errors for {!Head.fast_forward}. *) + + module Info : sig + include Info.S with type t = info + (** @inline *) + end + + type contents_key [@@deriving irmin] + type node_key [@@deriving irmin] + type commit_key [@@deriving irmin] + + (** Repositories. *) + module Repo : sig + (** {1 Repositories} + + A repository contains a set of branches. *) + + type t = repo + (** The type of repository handles. *) + + val v : Conf.t -> t Lwt.t + (** [v config] connects to a repository in a backend-specific manner. *) + + val config : t -> Conf.t + (** [config repo] is the configuration used to create [repo] *) + + include Closeable with type _ t := t + (** @inline *) + + val heads : t -> commit list Lwt.t + (** [heads] is {!Head.list}. *) + + val branches : t -> branch list Lwt.t + (** [branches] is {!Branch.list}. *) + + val export : + ?full:bool -> + ?depth:int -> + ?min:commit list -> + ?max:[ `Head | `Max of commit list ] -> + t -> + slice Lwt.t + (** [export t ~full ~depth ~min ~max] exports the store slice between [min] + and [max], using at most [depth] history depth (starting from the max). + + If [max] is `Head (also the default value), use the current [heads]. If + [min] is not specified, use an unbound past (but can still be limited by + [depth]). + + [depth] is used to limit the depth of the commit history. [None] here + means no limitation. + + If [full] is set (default is true), the full graph, including the + commits, nodes and contents, is exported, otherwise it is the commit + history graph only. *) + + val import : t -> slice -> (unit, [ `Msg of string ]) result Lwt.t + (** [import t s] imports the contents of the slice [s] in [t]. Does not + modify branches. *) + + type elt = + [ `Commit of commit_key + | `Node of node_key + | `Contents of contents_key + | `Branch of branch ] + [@@deriving irmin] + (** The type for elements iterated over by {!iter}. *) + + val default_pred_commit : t -> commit_key -> elt list Lwt.t + val default_pred_node : t -> node_key -> elt list Lwt.t + val default_pred_contents : t -> contents_key -> elt list Lwt.t + + val iter : + ?cache_size:int -> + min:elt list -> + max:elt list -> + ?edge:(elt -> elt -> unit Lwt.t) -> + ?branch:(branch -> unit Lwt.t) -> + ?commit:(commit_key -> unit Lwt.t) -> + ?node:(node_key -> unit Lwt.t) -> + ?contents:(contents_key -> unit Lwt.t) -> + ?skip_branch:(branch -> bool Lwt.t) -> + ?skip_commit:(commit_key -> bool Lwt.t) -> + ?skip_node:(node_key -> bool Lwt.t) -> + ?skip_contents:(contents_key -> bool Lwt.t) -> + ?pred_branch:(t -> branch -> elt list Lwt.t) -> + ?pred_commit:(t -> commit_key -> elt list Lwt.t) -> + ?pred_node:(t -> node_key -> elt list Lwt.t) -> + ?pred_contents:(t -> contents_key -> elt list Lwt.t) -> + ?rev:bool -> + t -> + unit Lwt.t + (** [iter t] iterates in topological order over the closure graph of [t]. If + [rev] is set (by default it is) the traversal is done in reverse order. + + [skip_branch], [skip_commit], [skip_node] and [skip_contents] allow the + traversal to be stopped when the corresponding objects are traversed. By + default no objects are skipped. + + The [branch], [commit], [node] and [contents] functions are called + whenever the corresponding objects are traversed. By default these + functions do nothing. These functions are not called on skipped objects. + + [pred_branch], [pred_commit], [pred_node] and [pred_contents] implicitly + define the graph underlying the traversal. By default they exactly match + the underlying Merkle graph of the repository [t]. These functions can + be used to traverse a slightly modified version of that graph, for + instance by modifying [pred_contents] to implicitly link structured + contents with other objects in the graph. + + The traversed objects are all included between [min] (included) and + [max] (included), following the Merkle graph order. Moreover, the [min] + boundary is extended as follows: + + - contents and node objects in [min] stop the traversal; their + predecessors are not traversed. + - commit objects in [min] stop the traversal for their commit + predecessors, but their sub-node are still traversed. This allows + users to define an inclusive range of commit to iterate over. + - branch objects in [min] implicitly add to [min] the commit they are + pointing to; this allow users to define the iteration between two + branches. + + [cache_size] is the size of the LRU used to store traversed objects. If + an entry is evicted from the LRU, it can be traversed multiple times by + {!Repo.iter}. When [cache_size] is [None] (the default), no entries is + ever evicted from the cache; hence every object is only traversed once, + at the cost of having to store all the traversed objects in memory. *) + + val breadth_first_traversal : + ?cache_size:int -> + max:elt list -> + ?branch:(branch -> unit Lwt.t) -> + ?commit:(commit_key -> unit Lwt.t) -> + ?node:(node_key -> unit Lwt.t) -> + ?contents:(contents_key -> unit Lwt.t) -> + ?pred_branch:(t -> branch -> elt list Lwt.t) -> + ?pred_commit:(t -> commit_key -> elt list Lwt.t) -> + ?pred_node:(t -> node_key -> elt list Lwt.t) -> + ?pred_contents:(t -> contents_key -> elt list Lwt.t) -> + t -> + unit Lwt.t + end + + val empty : repo -> t Lwt.t + (** [empty repo] is a temporary, empty store. Becomes a normal temporary store + after the first update. *) + + val main : repo -> t Lwt.t + (** [main r] is a persistent store based on [r]'s main branch. This operation + is cheap, can be repeated multiple times. *) + + val of_branch : repo -> branch -> t Lwt.t + (** [of_branch r name] is a persistent store based on the branch [name]. + Similar to {!main}, but use [name] instead of {!Irmin.Branch.S.main}. *) + + val of_commit : commit -> t Lwt.t + (** [of_commit c] is a temporary store, based on the commit [c]. + + Temporary stores do not have stable names: instead they can be addressed + using the hash of the current commit. Temporary stores are similar to + Git's detached heads. In a temporary store, all the operations are + performed relative to the current head and update operations can modify + the current head: the current stores's head will automatically become the + new head obtained after performing the update. *) + + val repo : t -> repo + (** [repo t] is the repository containing [t]. *) + + val tree : t -> tree Lwt.t + (** [tree t] is [t]'s current tree. Contents is not allowed at the root of the + tree. *) + + module Status : sig + type t = [ `Empty | `Branch of branch | `Commit of commit ] + (** The type for store status. *) + + val t : repo -> t Type.t + (** [t] is the value type for {!type-t}. *) + + val pp : t Fmt.t + (** [pp] is the pretty-printer for store status. *) + end + + val status : t -> Status.t + (** [status t] is [t]'s status. It can either be a branch, a commit or empty. *) + + (** Managing the store's heads. *) + module Head : sig + val list : repo -> commit list Lwt.t + (** [list t] is the list of all the heads in local store. Similar to + [git rev-list --all]. *) + + val find : t -> commit option Lwt.t + (** [find t] is the current head of the store [t]. This works for both + persistent and temporary branches. In the case of a persistent branch, + this involves getting the the head associated with the branch, so this + may block. In the case of a temporary store, it simply returns the + current head. Returns [None] if the store has no contents. Similar to + [git rev-parse HEAD]. *) + + val get : t -> commit Lwt.t + (** Same as {!find} but raise [Invalid_argument] if the store does not have + any contents. *) + + val set : t -> commit -> unit Lwt.t + (** [set t h] updates [t]'s contents with the contents of the commit [h]. + Can cause data loss as it discards the current contents. Similar to + [git reset --hard ]. *) + + val fast_forward : + t -> ?max_depth:int -> ?n:int -> commit -> (unit, ff_error) result Lwt.t + (** [fast_forward t h] is similar to {!set} but the [t]'s head is updated to + [h] only if [h] is stricly in the future of [t]'s current head. + [max_depth] or [n] are used to limit the search space of the lowest + common ancestors (see {!lcas}). + + The result is: + + - [Ok ()] if the operation is succesfull; + - [Error `No_change] if [h] is already [t]'s head; + - [Error `Rejected] if [h] is not in the strict future of [t]'s head. + - [Error e] if the history exploration has been cut before getting + useful results. In that case. the operation can be retried using + different parameters of [n] and [max_depth] to get better results. *) + + val test_and_set : + t -> test:commit option -> set:commit option -> bool Lwt.t + (** Same as {!set} but check that the value is [test] before updating to + [set]. Use {!set} or {!val-merge} instead if possible. *) + + val merge : + into:t -> + info:Info.f -> + ?max_depth:int -> + ?n:int -> + commit -> + (unit, Merge.conflict) result Lwt.t + (** [merge ~into:t ?max_head ?n commit] merges the contents of the commit + associated to [commit] into [t]. [max_depth] is the maximal depth used + for getting the lowest common ancestor. [n] is the maximum number of + lowest common ancestors. If present, [max_depth] or [n] are used to + limit the search space of the lowest common ancestors (see {!lcas}). *) + end + + module Hash : Hash.S with type t = hash + (** Object hashes. *) + + (** [Commit] defines immutable objects to describe store updates. *) + module Commit : sig + type t = commit + (** The type for store commits. *) + + val t : repo -> t Type.t + (** [t] is the value type for {!type-t}. *) + + val pp_hash : t Fmt.t + (** [pp] is the pretty-printer for commit. Display only the hash. *) + + val v : repo -> info:info -> parents:commit_key list -> tree -> commit Lwt.t + (** [v r i ~parents:p t] is the commit [c] such that: + + - [info c = i] + - [parents c = p] + - [tree c = t] *) + + val tree : commit -> tree + (** [tree c] is [c]'s root tree. *) + + val parents : commit -> commit_key list + (** [parents c] are [c]'s parents. *) + + val info : commit -> info + (** [info c] is [c]'s info. *) + + val hash : commit -> hash + (** [hash c] is [c]'s hash. *) + + (** {1 Import/Export} *) + + val key : commit -> commit_key + (** [key c] is [c]'s key. *) + + val of_key : repo -> commit_key -> commit option Lwt.t + (** [of_key r k] is the the commit object in [r] with key [k], or [None] if + no such commit object exists. *) + + val of_hash : repo -> hash -> commit option Lwt.t + (** [of_hash r h] is the commit object in [r] with hash [h], or [None] if no + such commit object is indexed in [r]. + + {b Note:} in stores for which {!commit_key} = {!type-hash}, this + function has identical behaviour to {!of_key}. *) + end + + (** [Contents] provides base functions for the store's contents. *) + module Contents : sig + include Contents.S with type t = contents + + (** {1 Import/Export} *) + + val hash : contents -> hash + (** [hash c] it [c]'s hash. *) + + val of_key : repo -> contents_key -> contents option Lwt.t + (** [of_key r k] is the contents object in [r] with key [k], or [None] if no + such contents object exists. *) + + val of_hash : repo -> hash -> contents option Lwt.t + (** [of_hash r h] is the contents object in [r] with hash [h], or [None] if + no such contents object is indexed in [r]. + + {b Note:} in stores for which {!contents_key} = {!type-hash}, this + function has identical behaviour to {!of_key}. *) + end + + (** Managing store's trees. *) + module Tree : sig + include + Tree.S + with type t := tree + and type step := step + and type path := path + and type metadata := metadata + and type contents := contents + and type contents_key := contents_key + and type node := node + and type hash := hash + + (** {1 Import/Export} *) + + type kinded_key = + [ `Contents of contents_key * metadata | `Node of node_key ] + [@@deriving irmin] + (** Keys in the Irmin store are tagged with the type of the value they + reference (either {!contents} or {!node}). In the [contents] case, the + key is paired with corresponding {!metadata}. *) + + val key : tree -> kinded_key option + (** [key t] is the key of tree [t] in the underlying repository, if it + exists. Tree objects that exist entirely in memory (such as those built + with {!of_concrete}) have no backend key until they are exported to a + repository, and so will return [None]. *) + + val find_key : Repo.t -> tree -> kinded_key option Lwt.t + (** [find_key r t] is the key of a tree object with the same hash as [t] in + [r], if such a key exists and is indexed. *) + + val of_key : Repo.t -> kinded_key -> tree option Lwt.t + (** [of_key r h] is the tree object in [r] having [h] as key, or [None] if + no such tree object exists. *) + + val shallow : Repo.t -> kinded_key -> tree + (** [shallow r h] is the shallow tree object with the key [h]. No check is + performed to verify if [h] actually exists in [r]. *) + + val hash : ?cache:bool -> tree -> hash + (** [hash t] is the hash of tree [t]. *) + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + (** Like {!kinded_key}, but with hashes as value references rather than + keys. *) + + val kinded_hash : ?cache:bool -> tree -> kinded_hash + (** [kinded_hash t] is [c]'s kinded hash. *) + + val of_hash : Repo.t -> kinded_hash -> tree option Lwt.t + (** [of_hash r h] is the tree object in [r] with hash [h], or [None] if no + such tree object is indexed in [r]. + + {b Note:} in stores for which {!node_key} = {!contents_key} = + {!type-hash}, this function has identical behaviour to {!of_key}. *) + + (** {1 Proofs} *) + + type ('proof, 'result) producer := + repo -> + kinded_key -> + (tree -> (tree * 'result) Lwt.t) -> + ('proof * 'result) Lwt.t + (** [produce r h f] runs [f] on top of a real store [r], producing a proof + and a result using the initial root hash [h]. + + The trees produced during [f]'s computation will carry the full history + of reads. This history will be reset when [f] is complete so subtrees + escaping the scope of [f] will not cause memory leaks. + + Calling [produce_proof] recursively has an undefined behaviour. *) + + type verifier_error = + [ `Proof_mismatch of string + | `Stream_too_long of string + | `Stream_too_short of string ] + [@@deriving irmin] + (** The type for errors associated with functions that verify proofs. *) + + type ('proof, 'result) verifier := + 'proof -> + (tree -> (tree * 'result) Lwt.t) -> + (tree * 'result, verifier_error) result Lwt.t + (** [verify p f] runs [f] in checking mode. [f] is a function that takes a + tree as input and returns a new version of the tree and a result. [p] is + a proof, that is a minimal representation of the tree that contains what + [f] should be expecting. + + Therefore, contrary to trees found in a storage, the contents of the + trees passed to [f] may not be available. For this reason, looking up a + value at some [path] can now produce three distinct outcomes: + + - A value [v] is present in the proof [p] and returned : + [find tree path] is a promise returning [Some v]; + - [path] is known to have no value in [tree] : [find tree path] is a + promise returning [None]; and + - [path] is known to have a value in [tree] but [p] does not provide it + because [f] should not need it: [verify] returns an error classifying + [path] as an invalid path (see below). + + The same semantics apply to all operations on the tree [t] passed to [f] + and on all operations on the trees built from [f]. + + The generated tree is the tree after [f] has completed. That tree is + disconnected from the backend. It is possible to run operations on it as + long as they don't require loading shallowed subtrees, otherwise it + would raise [Dangling_hash]. + + The result is [Error _] if the proof is rejected: + + - For tree proofs: when [p.before] is different from the hash of + [p.state]; + - For tree and stream proofs: when [p.after] is different from the hash + of [f p.state]; + - For tree and stream proofs: when [f p.state] tries to access paths + invalid paths in [p.state]; + - For stream proofs: when the proof is not empty once [f] is done. *) + + type tree_proof := Proof.tree Proof.t + (** The type for tree proofs. + + Guarantee that the given computation performs exactly the same state + operations as the generating computation, *in some order*. *) + + val produce_proof : (tree_proof, 'a) producer + (** [produce_proof] is the producer of tree proofs. *) + + val verify_proof : (tree_proof, 'a) verifier + (** [verify_proof] is the verifier of tree proofs. *) + + type stream_proof := Proof.stream Proof.t + (** The type for stream proofs. + + Guarantee that the given computation performs exactly the same state + operations as the generating computation, in the exact same order. + + Calling [fold] with [order = `Undefined] during the + production/verification of streamed proofs is undefined. *) + + val produce_stream : (stream_proof, 'a) producer + (** [produce_stream] is the producer of stream proofs. *) + + val verify_stream : (stream_proof, 'a) verifier + (** [verify_stream] is the verifier of stream proofs. *) + end + + (** {1 Reads} *) + + val kind : t -> path -> [ `Contents | `Node ] option Lwt.t + (** [kind] is {!Tree.kind} applied to [t]'s root tree. *) + + val list : t -> path -> (step * tree) list Lwt.t + (** [list t] is {!Tree.list} applied to [t]'s root tree. *) + + val mem : t -> path -> bool Lwt.t + (** [mem t] is {!Tree.mem} applied to [t]'s root tree. *) + + val mem_tree : t -> path -> bool Lwt.t + (** [mem_tree t] is {!Tree.mem_tree} applied to [t]'s root tree. *) + + val find_all : t -> path -> (contents * metadata) option Lwt.t + (** [find_all t] is {!Tree.find_all} applied to [t]'s root tree. *) + + val find : t -> path -> contents option Lwt.t + (** [find t] is {!Tree.find} applied to [t]'s root tree. *) + + val get_all : t -> path -> (contents * metadata) Lwt.t + (** [get_all t] is {!Tree.get_all} applied on [t]'s root tree. *) + + val get : t -> path -> contents Lwt.t + (** [get t] is {!Tree.get} applied to [t]'s root tree. *) + + val find_tree : t -> path -> tree option Lwt.t + (** [find_tree t] is {!Tree.find_tree} applied to [t]'s root tree. *) + + val get_tree : t -> path -> tree Lwt.t + (** [get_tree t k] is {!Tree.get_tree} applied to [t]'s root tree. *) + + type kinded_key := [ `Contents of contents_key | `Node of node_key ] + + val key : t -> path -> kinded_key option Lwt.t + (** [id t k] *) + + val hash : t -> path -> hash option Lwt.t + (** [hash t k] *) + + (** {1 Updates} *) + + type write_error = + [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] + [@@deriving irmin] + (** The type for write errors. + + - Merge conflict. + - Concurrent transactions are competing to get the current operation + committed and too many attemps have been tried (livelock). + - A "test and set" operation has failed and the current value is [v] + instead of the one we were waiting for. *) + + val set : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + contents -> + (unit, write_error) result Lwt.t + (** [set t k ~info v] sets [k] to the value [v] in [t]. Discard any previous + results but ensure that no operation is lost in the history. + + This function always uses {!Metadata.default} as metadata. Use {!set_tree} + with `[Contents (c, m)] for different ones. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val set_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + contents -> + unit Lwt.t + (** [set_exn] is like {!set} but raise [Failure _] instead of using a result + type. *) + + val set_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + tree -> + (unit, write_error) result Lwt.t + (** [set_tree] is like {!set} but for trees. *) + + val set_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + tree -> + unit Lwt.t + (** [set_tree] is like {!set_exn} but for trees. *) + + val remove : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + (unit, write_error) result Lwt.t + (** [remove t ~info k] remove any bindings to [k] in [t]. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val remove_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + unit Lwt.t + (** [remove_exn] is like {!remove} but raise [Failure _] instead of a using + result type. *) + + val test_and_set : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:contents option -> + set:contents option -> + (unit, write_error) result Lwt.t + (** [test_and_set ~test ~set] is like {!set} but it atomically checks that the + tree is [test] before modifying it to [set]. + + This function always uses {!Metadata.default} as metadata. Use + {!test_and_set_tree} with `[Contents (c, m)] for different ones. + + The result is [Error (`Test t)] if the current tree is [t] instead of + [test]. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val test_and_set_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:contents option -> + set:contents option -> + unit Lwt.t + (** [test_and_set_exn] is like {!test_and_set} but raise [Failure _] instead + of using a result type. *) + + val test_and_set_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:tree option -> + set:tree option -> + (unit, write_error) result Lwt.t + (** [test_and_set_tree] is like {!test_and_set} but for trees. *) + + val test_and_set_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:tree option -> + set:tree option -> + unit Lwt.t + (** [test_and_set_tree_exn] is like {!test_and_set_exn} but for trees. *) + + val merge : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + path -> + contents option -> + (unit, write_error) result Lwt.t + (** [merge ~old] is like {!set} but merge the current tree and the new tree + using [old] as ancestor in case of conflicts. + + This function always uses {!Metadata.default} as metadata. Use + {!merge_tree} with `[Contents (c, m)] for different ones. + + The result is [Error (`Conflict c)] if the merge failed with the conflict + [c]. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val merge_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + path -> + contents option -> + unit Lwt.t + (** [merge_exn] is like {!val-merge} but raise [Failure _] instead of using a + result type. *) + + val merge_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + path -> + tree option -> + (unit, write_error) result Lwt.t + (** [merge_tree] is like {!merge_tree} but for trees. *) + + val merge_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + path -> + tree option -> + unit Lwt.t + (** [merge_tree] is like {!merge_tree} but for trees. *) + + val with_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + path -> + (tree option -> tree option Lwt.t) -> + (unit, write_error) result Lwt.t + (** [with_tree t k ~info f] replaces {i atomically} the subtree [v] under [k] + in the store [t] by the contents of the tree [f v], using the commit info + [info ()]. + + If [v = f v] and [allow_empty] is unset (default) then, the operation is a + no-op. + + If [v != f v] and no other changes happen concurrently, [f v] becomes the + new subtree under [k]. If other changes happen concurrently to that + operations, the semantics depend on the value of [strategy]: + + - if [strategy = `Set], use {!set} and discard any concurrent updates to + [k]. + - if [strategy = `Test_and_set] (default), use {!test_and_set} and ensure + that no concurrent operations are updating [k]. + - if [strategy = `Merge], use {!val-merge} and ensure that concurrent + updates and merged with the values present at the beginning of the + transaction. + + {b Note:} Irmin transactions provides + {{:https://en.wikipedia.org/wiki/Snapshot_isolation} snapshot isolation} + guarantees: reads and writes are isolated in every transaction, but only + write conflicts are visible on commit. *) + + val with_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + path -> + (tree option -> tree option Lwt.t) -> + unit Lwt.t + (** [with_tree_exn] is like {!with_tree} but raise [Failure _] instead of + using a return type. *) + + (** {1 Clones} *) + + val clone : src:t -> dst:branch -> t Lwt.t + (** [clone ~src ~dst] makes [dst] points to [Head.get src]. [dst] is created + if needed. Remove the current contents en [dst] if [src] is {!empty}. *) + + (** {1 Watches} *) + + type watch + (** The type for store watches. *) + + val watch : t -> ?init:commit -> (commit Diff.t -> unit Lwt.t) -> watch Lwt.t + (** [watch t f] calls [f] every time the contents of [t]'s head is updated. + + {b Note:} even if [f] might skip some head updates, it will never be + called concurrently: all consecutive calls to [f] are done in sequence, so + we ensure that the previous one ended before calling the next one. *) + + val watch_key : + t -> + path -> + ?init:commit -> + ((commit * tree) Diff.t -> unit Lwt.t) -> + watch Lwt.t + (** [watch_key t key f] calls [f] every time the [key]'s value is added, + removed or updated. If the current branch is deleted, no signal is sent to + the watcher. *) + + val unwatch : watch -> unit Lwt.t + (** [unwatch w] disable [w]. Return once the [w] is fully disabled. *) + + (** {1 Merges and Common Ancestors} *) + + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Merge.conflict) result Lwt.t + (** The type for merge functions. *) + + val merge_into : into:t -> t merge + (** [merge_into ~into i t] merges [t]'s current branch into [x]'s current + branch using the info [i]. After that operation, the two stores are still + independent. Similar to [git merge ]. *) + + val merge_with_branch : t -> branch merge + (** Same as {!val-merge} but with a branch ID. *) + + val merge_with_commit : t -> commit merge + (** Same as {!val-merge} but with a commit_id. *) + + val lcas : + ?max_depth:int -> ?n:int -> t -> t -> (commit list, lca_error) result Lwt.t + (** [lca ?max_depth ?n msg t1 t2] returns the collection of least common + ancestors between the heads of [t1] and [t2] branches. + + - [max_depth] is the maximum depth of the exploration (default is + [max_int]). Return [Error `Max_depth_reached] if this depth is exceeded. + - [n] is the maximum expected number of lcas. Stop the exploration as soon + as [n] lcas are found. Return [Error `Too_many_lcas] if more [lcas] are + found. *) + + val lcas_with_branch : + t -> + ?max_depth:int -> + ?n:int -> + branch -> + (commit list, lca_error) result Lwt.t + (** Same as {!lcas} but takes a branch ID as argument. *) + + val lcas_with_commit : + t -> + ?max_depth:int -> + ?n:int -> + commit -> + (commit list, lca_error) result Lwt.t + (** Same as {!lcas} but takes a commmit as argument. *) + + (** {1 History} *) + + module History : Graph.Sig.P with type V.t = commit + (** An history is a DAG of heads. *) + + val history : + ?depth:int -> ?min:commit list -> ?max:commit list -> t -> History.t Lwt.t + (** [history ?depth ?min ?max t] is a view of the history of the store [t], of + depth at most [depth], starting from the [t]'s head (or from [max] if the + head is not set) and stopping at [min] if specified. *) + + val last_modified : ?depth:int -> ?n:int -> t -> path -> commit list Lwt.t + (** [last_modified ?number c k] is the list of the last [number] commits that + modified [path], in ascending order of date. [depth] is the maximum depth + to be explored in the commit graph, if any. Default value for [number] is + 1. *) + + (** Manipulate branches. *) + module Branch : sig + (** {1 Branch Store} + + Manipulate relations between {{!branch} branches} and {{!commit} + commits}. *) + + val mem : repo -> branch -> bool Lwt.t + (** [mem r b] is true iff [b] is present in [r]. *) + + val find : repo -> branch -> commit option Lwt.t + (** [find r b] is [Some c] iff [c] is bound to [b] in [t]. It is [None] if + [b] is not present in [t]. *) + + val get : repo -> branch -> commit Lwt.t + (** [get t b] is similar to {!find} but raise [Invalid_argument] if [b] is + not present in [t]. *) + + val set : repo -> branch -> commit -> unit Lwt.t + (** [set t b c] bounds [c] to [b] in [t]. *) + + val remove : repo -> branch -> unit Lwt.t + (** [remove t b] removes [b] from [t]. *) + + val list : repo -> branch list Lwt.t + (** [list t] is the list of branches present in [t]. *) + + val watch : + repo -> + branch -> + ?init:commit -> + (commit Diff.t -> unit Lwt.t) -> + watch Lwt.t + (** [watch t b f] calls [f] on every change in [b]. *) + + val watch_all : + repo -> + ?init:(branch * commit) list -> + (branch -> commit Diff.t -> unit Lwt.t) -> + watch Lwt.t + (** [watch_all t f] calls [f] on every branch-related change in [t], + including creation/deletion events. *) + + include Branch.S with type t = branch + (** Base functions for branches. *) + end + + (** [Path] provides base functions for the stores's paths. *) + module Path : Path.S with type t = path and type step = step + + module Metadata : Metadata.S with type t = metadata + (** [Metadata] provides base functions for node metadata. *) + + (** Backend functions, which might be used by the backends. *) + module Backend : + Backend.S + with module Schema = Schema + with type Slice.t = slice + and type Repo.t = repo + and module Hash = Hash + and module Node.Path = Path + and type Contents.key = contents_key + and type Node.key = node_key + and type Commit.key = commit_key + + type Remote.t += + | E of Backend.Remote.endpoint + (** Extend the [remote] type with [endpoint]. *) + + (** {2 Converters to backend types} *) + + val of_backend_node : repo -> Backend.Node.value -> node + val to_backend_node : node -> Backend.Node.value Lwt.t + val to_backend_portable_node : node -> Backend.Node_portable.t Lwt.t + + val to_backend_commit : commit -> Backend.Commit.value + (** [to_backend_commit c] is the backend commit object associated with the + commit [c]. *) + + val of_backend_commit : + repo -> Backend.Commit.Key.t -> Backend.Commit.value -> commit + (** [of_backend_commit r k c] is the commit associated with the backend commit + object [c] that hash key [k] in [r]. *) + + val save_contents : + [> write ] Backend.Contents.t -> contents -> contents_key Lwt.t + (** Save a content into the database *) + + val save_tree : + ?clear:bool -> + repo -> + [> write ] Backend.Contents.t -> + [> read_write ] Backend.Node.t -> + tree -> + kinded_key Lwt.t + (** Save a tree into the database. Does not do any reads. If [clear] is set + (it is by default), the tree cache will be cleared after the save. *) + + (** {Deprecated} *) + + val master : repo -> t Lwt.t + [@@ocaml.deprecated "Use `main` instead."] + (** @deprecated Use {!main} instead *) +end + +module type S = sig + type hash + + (** @inline *) + include + S_generic_key + with type Schema.Hash.t = hash + and type hash := hash + and type contents_key = hash + and type node_key = hash + and type commit_key = hash +end + +module S_is_a_generic_keyed (X : S) : S_generic_key = X + +module type Maker_generic_key = sig + type endpoint + + include Key.Store_spec.S + + module Make (Schema : Schema.S) : + S_generic_key + with module Schema = Schema + and type Backend.Remote.endpoint = endpoint + and type contents_key = (Schema.Hash.t, Schema.Contents.t) contents_key + and type node_key = Schema.Hash.t node_key + and type commit_key = Schema.Hash.t commit_key +end + +module type Maker = + Maker_generic_key + with type ('h, _) contents_key = 'h + and type 'h node_key = 'h + and type 'h commit_key = 'h + +module type Json_tree = functor + (Store : S with type Schema.Contents.t = Contents.json) + -> sig + include Contents.S with type t = Contents.json + + val to_concrete_tree : t -> Store.Tree.concrete + val of_concrete_tree : Store.Tree.concrete -> t + + val get_tree : Store.tree -> Store.path -> t Lwt.t + (** Extract a [json] value from tree at the given key. *) + + val set_tree : Store.tree -> Store.path -> t -> Store.tree Lwt.t + (** Project a [json] value onto a tree at the given key. *) + + val get : Store.t -> Store.path -> t Lwt.t + (** Extract a [json] value from a store at the given key. *) + + val set : + Store.t -> Store.path -> t -> info:(unit -> Store.info) -> unit Lwt.t + (** Project a [json] value onto a store at the given key. *) +end + +module type KV_generic_key = + S_generic_key + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Branch.t = string + +module type KV = + S + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Branch.t = string + +module type KV_maker_generic_key = sig + type endpoint + type metadata + type hash + + include Key.Store_spec.S + + module Make (C : Contents.S) : + KV_generic_key + with module Schema.Contents = C + and type Schema.Metadata.t = metadata + and type Backend.Remote.endpoint = endpoint + and type Schema.Hash.t = hash + and type contents_key = (hash, C.t) contents_key + and type node_key = hash node_key + and type commit_key = hash commit_key +end + +module type KV_maker = + KV_maker_generic_key + with type ('h, _) contents_key = 'h + and type 'h node_key = 'h + and type 'h commit_key = 'h + +module type Sigs = sig + module type S = S + module type Maker = Maker + module type Json_tree = Json_tree + module type KV = KV + module type KV_maker = KV_maker + + module Generic_key : sig + module type S = S_generic_key + module type KV = KV_generic_key + module type Maker = Maker_generic_key + module type KV_maker = KV_maker_generic_key + end + + type Remote.t += + | Store : (module Generic_key.S with type t = 'a) * 'a -> Remote.t + + module Make (B : Backend.S) : + Generic_key.S + with module Schema = B.Schema + and type slice = B.Slice.t + and type repo = B.Repo.t + and type contents_key = B.Contents.key + and type node_key = B.Node.key + and type commit_key = B.Commit.key + and module Backend = B + + module Json_tree : Json_tree + (** [Json_tree] is used to project JSON values onto trees. Instead of the + entire object being stored under one key, it is split across several keys + starting at the specified root key. *) +end diff --git a/vendors/irmin/src/irmin/store_properties.ml b/vendors/irmin/src/irmin/store_properties.ml new file mode 100644 index 0000000000000000000000000000000000000000..8485c2f65e223932cb601e4ec5b4cb535f139b08 --- /dev/null +++ b/vendors/irmin/src/irmin/store_properties.ml @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Store_properties_intf + +exception Closed diff --git a/vendors/irmin/src/irmin/store_properties.mli b/vendors/irmin/src/irmin/store_properties.mli new file mode 100644 index 0000000000000000000000000000000000000000..5ac3f90862048fca260f81e1b109ecd022c198ea --- /dev/null +++ b/vendors/irmin/src/irmin/store_properties.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Store_properties_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/store_properties_intf.ml b/vendors/irmin/src/irmin/store_properties_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..ce56bf71dd6b250677854251349a144ad8d3145f --- /dev/null +++ b/vendors/irmin/src/irmin/store_properties_intf.ml @@ -0,0 +1,72 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +module type Batch = sig + type 'a t + + val batch : read t -> ([ read | write ] t -> 'a Lwt.t) -> 'a Lwt.t + (** [batch t f] applies the writes in [f] in a separate batch. The exact + guarantees depend on the implementation. *) +end + +module type Closeable = sig + type 'a t + + val close : 'a t -> unit Lwt.t + (** [close t] frees up all the resources associated with [t]. Any operations + run on a closed handle will raise [Closed]. *) +end + +module type Of_config = sig + type 'a t + + val v : Conf.t -> read t Lwt.t + (** [v config] is a function returning fresh store handles, with the + configuration [config], which is provided by the backend. *) +end + +module type Clearable = sig + type 'a t + + val clear : 'a t -> unit Lwt.t + (** Clear the store. This operation is expected to be slow. *) +end + +module type Sigs = sig + exception Closed + + module type Batch = sig + include Batch + (** @inline *) + end + + module type Closeable = sig + include Closeable + (** @inline *) + end + + module type Of_config = sig + include Of_config + (** @inline *) + end + + module type Clearable = sig + include Clearable + (** @inline *) + end +end diff --git a/vendors/irmin/src/irmin/sync.ml b/vendors/irmin/src/irmin/sync.ml new file mode 100644 index 0000000000000000000000000000000000000000..513c72b689946865851453d20a5eada047ce4a29 --- /dev/null +++ b/vendors/irmin/src/irmin/sync.ml @@ -0,0 +1,221 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Sync_intf + +module type REMOTE = Remote.S + +let invalid_argf fmt = Fmt.kstr Lwt.fail_invalid_arg fmt +let src = Logs.Src.create "irmin.sync" ~doc:"Irmin remote sync" + +module Log = (val Logs.src_log src : Logs.LOG) + +let remote_store m x = Store.Store (m, x) + +module Make (S : Store.Generic_key.S) = struct + module B = S.Backend.Remote + + type db = S.t + type commit = S.commit + type commit_key = S.commit_key [@@deriving irmin ~pp] + type info = S.info + + let conv dx dy = + let dx_to_bin_string = Type.(unstage (to_bin_string dx)) in + let dy_of_bin_string = Type.(unstage (of_bin_string dy)) in + Type.stage (fun x -> dy_of_bin_string (dx_to_bin_string x)) + + let convert_slice (type r s) (module RP : Backend.S with type Slice.t = r) + (module SP : Backend.S with type Slice.t = s) r = + let conv_contents_k = + Type.unstage (conv RP.Contents.Hash.t SP.Contents.Hash.t) + in + let conv_contents_v = + Type.unstage (conv RP.Contents.Val.t SP.Contents.Val.t) + in + let conv_node_k = Type.unstage (conv RP.Node.Hash.t SP.Node.Hash.t) in + let conv_node_v = Type.unstage (conv RP.Node.Val.t SP.Node.Val.t) in + let conv_commit_k = Type.unstage (conv RP.Commit.Hash.t SP.Commit.Hash.t) in + let conv_commit_v = Type.unstage (conv RP.Commit.Val.t SP.Commit.Val.t) in + let* s = SP.Slice.empty () in + let* () = + RP.Slice.iter r (function + | `Contents (k, v) -> ( + let k = conv_contents_k k in + let v = conv_contents_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Contents (k, v)) + | _ -> Lwt.return_unit) + | `Node (k, v) -> ( + let k = conv_node_k k in + let v = conv_node_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Node (k, v)) + | _ -> Lwt.return_unit) + | `Commit (k, v) -> ( + let k = conv_commit_k k in + let v = conv_commit_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Commit (k, v)) + | _ -> Lwt.return_unit)) + in + Lwt.return s + + let convs src dst l = + let conv = Type.unstage (conv src dst) in + List.fold_left + (fun acc x -> match conv x with Ok x -> x :: acc | _ -> acc) + [] l + + let pp_branch = Type.pp S.Branch.t + + type status = [ `Empty | `Head of commit ] + + let pp_status ppf = function + | `Empty -> Fmt.string ppf "empty" + | `Head c -> S.Commit.pp_hash ppf c + + let status_t t = + let open Type in + variant "status" (fun empty head -> function + | `Empty -> empty | `Head c -> head c) + |~ case0 "empty" `Empty + |~ case1 "head" S.(commit_t @@ repo t) (fun c -> `Head c) + |> sealv + + let fetch t ?depth remote = + match remote with + | Store.Store ((module R), r) -> ( + [%log.debug "fetch store"]; + let s_repo = S.repo t in + let r_repo = R.repo r in + let conv = + Type.unstage (conv R.(commit_t r_repo) S.(commit_t s_repo)) + in + let* min = S.Repo.heads s_repo in + let min = convs S.(commit_t s_repo) R.(commit_t r_repo) min in + R.Head.find r >>= function + | None -> Lwt.return (Ok `Empty) + | Some h -> ( + let* r_slice = + R.Repo.export (R.repo r) ?depth ~min ~max:(`Max [ h ]) + in + let* s_slice = + convert_slice (module R.Backend) (module S.Backend) r_slice + in + S.Repo.import s_repo s_slice >|= function + | Error e -> Error e + | Ok () -> ( + match conv h with Ok h -> Ok (`Head h) | Error e -> Error e))) + | S.E e -> ( + match S.status t with + | `Empty | `Commit _ -> Lwt.return (Ok `Empty) + | `Branch br -> ( + [%log.debug "Fetching branch %a" pp_branch br]; + let* g = B.v (S.repo t) in + B.fetch g ?depth e br >>= function + | Error _ as e -> Lwt.return e + | Ok (Some key) -> ( + [%log.debug "Fetched %a" pp_commit_key key]; + S.Commit.of_key (S.repo t) key >|= function + | None -> Ok `Empty + | Some x -> Ok (`Head x)) + | Ok None -> ( + S.Head.find t >>= function + | Some h -> Lwt.return (Ok (`Head h)) + | None -> Lwt.return (Ok `Empty)))) + | _ -> Lwt.return (Error (`Msg "fetch operation is not available")) + + let fetch_exn t ?depth remote = + fetch t ?depth remote >>= function + | Ok h -> Lwt.return h + | Error (`Msg e) -> invalid_argf "Sync.fetch_exn: %s" e + + type pull_error = [ `Msg of string | Merge.conflict ] + + let pp_pull_error ppf = function + | `Msg s -> Fmt.string ppf s + | `Conflict c -> Fmt.pf ppf "conflict: %s" c + + let pull t ?depth remote kind : (status, pull_error) result Lwt.t = + fetch t ?depth remote >>= function + | Error e -> Lwt.return (Error (e :> pull_error)) + | Ok (`Head k) -> ( + match kind with + | `Set -> S.Head.set t k >|= fun () -> Ok (`Head k) + | `Merge info -> ( + S.Head.merge ~into:t ~info k >>= function + | Ok () -> Lwt.return (Ok (`Head k)) + | Error e -> Lwt.return (Error (e :> pull_error)))) + | Ok `Empty -> Lwt.return (Ok `Empty) + + let pull_exn t ?depth remote kind = + pull t ?depth remote kind >>= function + | Ok x -> Lwt.return x + | Error e -> invalid_argf "Sync.pull_exn: %a" pp_pull_error e + + type push_error = [ `Msg of string | `Detached_head ] + + let pp_push_error ppf = function + | `Msg s -> Fmt.string ppf s + | `Detached_head -> Fmt.string ppf "cannot push to a non-persistent store" + + let push t ?depth remote = + [%log.debug "push"]; + match remote with + | Store.Store ((module R), r) -> ( + S.Head.find t >>= function + | None -> Lwt.return (Ok `Empty) + | Some h -> ( + [%log.debug "push store"]; + let* min = R.Repo.heads (R.repo r) in + let r_repo = R.repo r in + let s_repo = S.repo t in + let min = convs R.(commit_t r_repo) S.(commit_t s_repo) min in + let conv = + Type.unstage (conv S.(commit_t s_repo) R.(commit_t r_repo)) + in + let* s_slice = S.Repo.export (S.repo t) ?depth ~min in + let* r_slice = + convert_slice (module S.Backend) (module R.Backend) s_slice + in + R.Repo.import (R.repo r) r_slice >>= function + | Error e -> Lwt.return (Error (e :> push_error)) + | Ok () -> ( + match conv h with + | Error e -> Lwt.return (Error (e :> push_error)) + | Ok h -> + R.Head.set r h >>= fun () -> + let+ head = S.Head.get t in + Ok (`Head head)))) + | S.E e -> ( + match S.status t with + | `Empty -> Lwt.return (Ok `Empty) + | `Commit _ -> Lwt.return (Error `Detached_head) + | `Branch br -> ( + let* head = S.of_branch (S.repo t) br >>= S.Head.get in + let* g = B.v (S.repo t) in + B.push g ?depth e br >>= function + | Ok () -> Lwt.return (Ok (`Head head)) + | Error err -> Lwt.return (Error (err :> push_error)))) + | _ -> Lwt.return (Error (`Msg "push operation is not available")) + + let push_exn t ?depth remote = + push t ?depth remote >>= function + | Ok x -> Lwt.return x + | Error e -> invalid_argf "Sync.push_exn: %a" pp_push_error e +end diff --git a/vendors/irmin/src/irmin/sync.mli b/vendors/irmin/src/irmin/sync.mli new file mode 100644 index 0000000000000000000000000000000000000000..7a9e317dee37df4747f22fe4abde93b657d17e9c --- /dev/null +++ b/vendors/irmin/src/irmin/sync.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Store Synchronisation. *) + +include Sync_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/sync_intf.ml b/vendors/irmin/src/irmin/sync_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..1260e8665ca4285bd8bdd59684b97facf581e397 --- /dev/null +++ b/vendors/irmin/src/irmin/sync_intf.ml @@ -0,0 +1,102 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Native Synchronization} *) + + type db + (** Type type for store handles. *) + + type commit + (** The type for store heads. *) + + type status = [ `Empty | `Head of commit ] + (** The type for remote status. *) + + type info + (** The type for commit info. *) + + val status_t : db -> status Type.t + (** [status_t db] is the value type for {!status} of remote [db]. *) + + val pp_status : status Fmt.t + (** [pp_status] pretty-prints return statuses. *) + + val fetch : + db -> ?depth:int -> Remote.t -> (status, [ `Msg of string ]) result Lwt.t + (** [fetch t ?depth r] populate the local store [t] with objects from the + remote store [r], using [t]'s current branch. The [depth] parameter limits + the history depth. Return [`Empty] if either the local or remote store do + not have a valid head. *) + + val fetch_exn : db -> ?depth:int -> Remote.t -> status Lwt.t + (** Same as {!fetch} but raise [Invalid_argument] if either the local or + remote store do not have a valid head. *) + + type pull_error = [ `Msg of string | Merge.conflict ] + (** The type for pull errors. *) + + val pp_pull_error : pull_error Fmt.t + (** [pp_pull_error] pretty-prints pull errors. *) + + val pull : + db -> + ?depth:int -> + Remote.t -> + [ `Merge of unit -> info | `Set ] -> + (status, pull_error) result Lwt.t + (** [pull t ?depth r s] is similar to {{!Sync.fetch} fetch} but it also + updates [t]'s current branch. [s] is the update strategy: + + - [`Merge] uses [Head.merge]. Can return a conflict. + - [`Set] uses [S.Head.set]. *) + + val pull_exn : + db -> + ?depth:int -> + Remote.t -> + [ `Merge of unit -> info | `Set ] -> + status Lwt.t + (** Same as {!pull} but raise [Invalid_arg] in case of conflict. *) + + type push_error = [ `Msg of string | `Detached_head ] + (** The type for push errors. *) + + val pp_push_error : push_error Fmt.t + (** [pp_push_error] pretty-prints push errors. *) + + val push : db -> ?depth:int -> Remote.t -> (status, push_error) result Lwt.t + (** [push t ?depth r] populates the remote store [r] with objects from the + current store [t], using [t]'s current branch. If [b] is [t]'s current + branch, [push] also updates the head of [b] in [r] to be the same as in + [t]. + + {b Note:} {e Git} semantics is to update [b] only if the new head if more + recent. This is not the case in {e Irmin}. *) + + val push_exn : db -> ?depth:int -> Remote.t -> status Lwt.t + (** Same as {!push} but raise [Invalid_argument] if an error happens. *) +end + +module type Sigs = sig + module type S = S + + val remote_store : + (module Store.Generic_key.S with type t = 'a) -> 'a -> Remote.t + + module Make (X : Store.Generic_key.S) : + S with type db = X.t and type commit = X.commit and type info = X.info +end diff --git a/vendors/irmin/src/irmin/tree.ml b/vendors/irmin/src/irmin/tree.ml new file mode 100644 index 0000000000000000000000000000000000000000..616567d90e602772fe3edcb044b367a3fea17c93 --- /dev/null +++ b/vendors/irmin/src/irmin/tree.ml @@ -0,0 +1,2846 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Tree_intf + +let src = Logs.Src.create "irmin.tree" ~doc:"Persistent lazy trees for Irmin" + +module Log = (val Logs.src_log src : Logs.LOG) + +type fuzzy_bool = False | True | Maybe +type ('a, 'r) cont = ('a -> 'r) -> 'r +type ('a, 'r) cont_lwt = ('a, 'r Lwt.t) cont + +let ok x = Lwt.return (Ok x) + +(* assume l1 and l2 are key-sorted *) +let alist_iter2 compare_k f l1 l2 = + let rec aux l1 l2 = + match (l1, l2) with + | [], t -> List.iter (fun (key, v) -> f key (`Right v)) t + | t, [] -> List.iter (fun (key, v) -> f key (`Left v)) t + | (k1, v1) :: t1, (k2, v2) :: t2 -> ( + match compare_k k1 k2 with + | 0 -> + f k1 (`Both (v1, v2)); + (aux [@tailcall]) t1 t2 + | x -> + if x < 0 then ( + f k1 (`Left v1); + (aux [@tailcall]) t1 l2) + else ( + f k2 (`Right v2); + (aux [@tailcall]) l1 t2)) + in + aux l1 l2 + +(* assume l1 and l2 are key-sorted *) +let alist_iter2_lwt compare_k f l1 l2 = + let l3 = ref [] in + alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; + Lwt_list.iter_s (fun b -> b >>= fun () -> Lwt.return_unit) (List.rev !l3) + +exception Backend_invariant_violation of string +exception Assertion_failure of string + +let backend_invariant_violation fmt = + Fmt.kstr (fun s -> raise (Backend_invariant_violation s)) fmt + +let assertion_failure fmt = Fmt.kstr (fun s -> raise (Assertion_failure s)) fmt + +module Make (P : Backend.S) = struct + type counters = { + mutable contents_hash : int; + mutable contents_find : int; + mutable contents_add : int; + mutable contents_mem : int; + mutable node_hash : int; + mutable node_mem : int; + mutable node_index : int; + mutable node_add : int; + mutable node_find : int; + mutable node_val_v : int; + mutable node_val_find : int; + mutable node_val_list : int; + } + [@@deriving irmin] + + let dump_counters ppf t = Type.pp_json ~minify:false counters_t ppf t + + let fresh_counters () = + { + contents_hash = 0; + contents_add = 0; + contents_find = 0; + contents_mem = 0; + node_hash = 0; + node_mem = 0; + node_index = 0; + node_add = 0; + node_find = 0; + node_val_v = 0; + node_val_find = 0; + node_val_list = 0; + } + + let reset_counters t = + t.contents_hash <- 0; + t.contents_add <- 0; + t.contents_find <- 0; + t.contents_mem <- 0; + t.node_hash <- 0; + t.node_mem <- 0; + t.node_index <- 0; + t.node_add <- 0; + t.node_find <- 0; + t.node_val_v <- 0; + t.node_val_find <- 0; + t.node_val_list <- 0 + + let cnt = fresh_counters () + + module Path = struct + include P.Node.Path + + let fold_right t ~f ~init = + let steps = map t Fun.id in + List.fold_right f steps init + end + + module Metadata = P.Node.Metadata + module Irmin_proof = Proof + module Tree_proof = Proof.Make (P.Contents.Val) (P.Hash) (Path) (Metadata) + module Env = Proof.Env (P) (Tree_proof) + + let merge_env x y = + match (Env.is_empty x, Env.is_empty y) with + | true, _ -> Ok y + | _, true -> Ok x + | false, false -> Error (`Conflict "merge env") + + module Hashes = Hash.Set.Make (P.Hash) + + module StepMap = struct + module X = struct + type t = Path.step [@@deriving irmin ~compare] + end + + include Map.Make (X) + + let stdlib_merge = merge + + include Merge.Map (X) + + let to_array m = + let length = cardinal m in + if length = 0 then [||] + else + let arr = Array.make length (choose m) in + let (_ : int) = + fold + (fun k v i -> + arr.(i) <- (k, v); + i + 1) + m 0 + in + arr + end + + type metadata = Metadata.t [@@deriving irmin ~equal] + type path = Path.t [@@deriving irmin ~pp] + type hash = P.Hash.t [@@deriving irmin ~pp ~equal ~compare] + type step = Path.step [@@deriving irmin ~pp ~compare] + type contents = P.Contents.Val.t [@@deriving irmin ~equal ~pp] + type repo = P.Repo.t + type marks = Hashes.t + + type error = + [ `Dangling_hash of hash | `Pruned_hash of hash | `Portable_value ] + + type 'a or_error = ('a, error) result + type 'a force = [ `True | `False of path -> 'a -> 'a Lwt.t ] + type uniq = [ `False | `True | `Marks of marks ] + type ('a, 'b) folder = path -> 'b -> 'a -> 'a Lwt.t + + type depth = [ `Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int ] + [@@deriving irmin] + + let dummy_marks = Hashes.create ~initial_slots:0 () + let empty_marks () = Hashes.create ~initial_slots:39 () + + exception Pruned_hash of { context : string; hash : hash } + exception Dangling_hash of { context : string; hash : hash } + exception Portable_value of { context : string } + + let () = + Printexc.register_printer (function + | Dangling_hash { context; hash } -> + Some + (Fmt.str "Irmin.Tree.%s: encountered dangling hash %a" context + pp_hash hash) + | Pruned_hash { context; hash } -> + Some + (Fmt.str "Irmin.Tree.%s: encountered pruned hash %a" context pp_hash + hash) + | Portable_value { context } -> + Some + (Fmt.str "Irmin.Tree.%s: unsupported operation on portable tree." + context) + | _ -> None) + + let err_pruned_hash h = Error (`Pruned_hash h) + let err_dangling_hash h = Error (`Dangling_hash h) + let err_portable_value = Error `Portable_value + let pruned_hash_exn context hash = raise (Pruned_hash { context; hash }) + let portable_value_exn context = raise (Portable_value { context }) + + let get_ok : type a. string -> a or_error -> a = + fun context -> function + | Ok x -> x + | Error (`Pruned_hash hash) -> pruned_hash_exn context hash + | Error (`Dangling_hash hash) -> raise (Dangling_hash { context; hash }) + | Error `Portable_value -> portable_value_exn context + + type 'key ptr_option = Key of 'key | Hash of hash | Ptr_none + (* NOTE: given the choice, we prefer caching [Key] over [Hash] as it can + be used to avoid storing duplicate contents values on export. *) + + module Contents = struct + type key = P.Contents.Key.t [@@deriving irmin] + type v = Key of repo * key | Value of contents | Pruned of hash + type nonrec ptr_option = key ptr_option + + type info = { + mutable ptr : ptr_option; + mutable value : contents option; + env : Env.t; + } + + type t = { mutable v : v; info : info } + + let info_is_empty i = i.ptr = Ptr_none && i.value = None + + let v = + let open Type in + variant "Node.Contents.v" (fun key value pruned (v : v) -> + match v with + | Key (_, x) -> key x + | Value v -> value v + | Pruned h -> pruned h) + |~ case1 "key" P.Contents.Key.t (fun _ -> assert false) + |~ case1 "value" P.Contents.Val.t (fun v -> Value v) + |~ case1 "pruned" hash_t (fun h -> Pruned h) + |> sealv + + let clear_info i = + if not (info_is_empty i) then ( + i.value <- None; + i.ptr <- Ptr_none) + + let clear t = clear_info t.info + + let of_v ~env (v : v) = + let ptr, value = + match v with + | Key (_, k) -> ((Key k : ptr_option), None) + | Value v -> (Ptr_none, Some v) + | Pruned _ -> (Ptr_none, None) + in + let info = { ptr; value; env } in + { v; info } + + let export ?clear:(c = true) repo t k = + let ptr = t.info.ptr in + if c then clear t; + match (t.v, ptr) with + | Key (repo', _), (Ptr_none | Hash _) -> + if repo != repo' then t.v <- Key (repo, k) + | Key (repo', _), Key k -> if repo != repo' then t.v <- Key (repo, k) + | Value _, (Ptr_none | Hash _) -> t.v <- Key (repo, k) + | Value _, Key k -> t.v <- Key (repo, k) + | Pruned _, _ -> + (* The main export function never exports a pruned position. *) + assert false + + let of_value c = of_v (Value c) + let of_key repo k = of_v (Key (repo, k)) + let pruned h = of_v (Pruned h) + + let cached_hash t = + match (t.v, t.info.ptr) with + | Key (_, k), _ -> Some (P.Contents.Key.to_hash k) + | Value _, Key k -> Some (P.Contents.Key.to_hash k) + | Pruned h, _ -> Some h + | Value _, Hash h -> Some h + | Value _, Ptr_none -> None + + let cached_key t = + match (t.v, t.info.ptr) with + | Key (_, k), _ -> Some k + | (Value _ | Pruned _), Key k -> Some k + | (Value _ | Pruned _), (Hash _ | Ptr_none) -> None + + let cached_value t = + match (t.v, t.info.value) with + | Value v, None -> Some v + | (Key _ | Value _ | Pruned _), (Some _ as v) -> v + | (Key _ | Pruned _), None -> ( + match cached_hash t with + | None -> None + | Some h -> ( + match Env.find_contents t.info.env h with + | None -> None + | Some c -> Some c)) + + let hash ?(cache = true) c = + match cached_hash c with + | Some k -> k + | None -> ( + match cached_value c with + | None -> assert false + | Some v -> + cnt.contents_hash <- cnt.contents_hash + 1; + let h = P.Contents.Hash.hash v in + assert (c.info.ptr = Ptr_none); + if cache then c.info.ptr <- Hash h; + h) + + let key t = + match t.v with Key (_, k) -> Some k | Value _ | Pruned _ -> None + + let value_of_key ~cache t repo k = + cnt.contents_find <- cnt.contents_find + 1; + let h = P.Contents.Key.to_hash k in + let+ v_opt = P.Contents.find (P.Repo.contents_t repo) k in + Option.iter (Env.add_contents_from_store t.info.env h) v_opt; + match v_opt with + | None -> err_dangling_hash h + | Some v -> + if cache then t.info.value <- v_opt; + Ok v + + let to_value ~cache t = + match cached_value t with + | Some v -> ok v + | None -> ( + match t.v with + | Value _ -> assert false (* [cached_value == None] *) + | Key (repo, k) -> value_of_key ~cache t repo k + | Pruned h -> err_pruned_hash h |> Lwt.return) + + let force = to_value ~cache:true + + let force_exn t = + let+ v = force t in + get_ok "force" v + + let equal (x : t) (y : t) = + x == y + || + match (cached_hash x, cached_hash y) with + | Some x, Some y -> equal_hash x y + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> equal_contents x y + | _ -> equal_hash (hash ~cache:true x) (hash ~cache:true y)) + + let compare (x : t) (y : t) = + if x == y then 0 + else compare_hash (hash ~cache:true x) (hash ~cache:true y) + + let t = + let of_v v = of_v ~env:(Env.empty ()) v in + Type.map ~equal ~compare v of_v (fun t -> t.v) + + let merge : t Merge.t = + let f ~old x y = + let old = + Merge.bind_promise old (fun old () -> + let+ c = to_value ~cache:true old >|= Option.of_result in + Ok (Some c)) + in + match merge_env x.info.env y.info.env with + | Error _ as e -> Lwt.return e + | Ok env -> ( + let* x = to_value ~cache:true x >|= Option.of_result in + let* y = to_value ~cache:true y >|= Option.of_result in + Merge.(f P.Contents.Val.merge) ~old x y >|= function + | Ok (Some c) -> Ok (of_value ~env c) + | Ok None -> Error (`Conflict "empty contents") + | Error _ as e -> e) + in + Merge.v t f + + let fold ~force ~cache ~path f_value f_tree t acc = + match force with + | `True -> + let* c = to_value ~cache t in + f_value path (get_ok "fold" c) acc >>= f_tree path + | `False skip -> ( + match cached_value t with + | None -> skip path acc + | Some c -> f_value path c acc >>= f_tree path) + end + + module Node = struct + type value = P.Node.Val.t [@@deriving irmin ~equal ~pp] + type key = P.Node.Key.t [@@deriving irmin] + type nonrec ptr_option = key ptr_option + + open struct + module Portable = P.Node_portable + end + + type portable = Portable.t [@@deriving irmin ~equal ~pp] + + (* [elt] is a tree *) + type elt = [ `Node of t | `Contents of Contents.t * Metadata.t ] + and update = Add of elt | Remove + and updatemap = update StepMap.t + and map = elt StepMap.t + + and info = { + mutable value : value option; + mutable map : map option; + mutable ptr : ptr_option; + mutable findv_cache : map option; + env : Env.t; + } + + and v = + | Map of map + | Key of repo * key + | Value of repo * value * updatemap option + | Portable_dirty of portable * updatemap + | Pruned of hash + + and t = { mutable v : v; info : info } + (** For discussion of [t.v]'s states, see {!Tree_intf.S.inspect}. + + [t.info.map] is only populated during a call to [Node.to_map]. *) + + let elt_t (t : t Type.t) : elt Type.t = + let open Type in + variant "Node.value" (fun node contents contents_m -> function + | `Node x -> node x + | `Contents (c, m) -> + if equal_metadata m Metadata.default then contents c + else contents_m (c, m)) + |~ case1 "Node" t (fun x -> `Node x) + |~ case1 "Contents" Contents.t (fun x -> `Contents (x, Metadata.default)) + |~ case1 "Contents-x" (pair Contents.t Metadata.t) (fun x -> `Contents x) + |> sealv + + let stepmap_t : 'a. 'a Type.t -> 'a StepMap.t Type.t = + fun elt -> + let open Type in + let to_map x = + List.fold_left (fun acc (k, v) -> StepMap.add k v acc) StepMap.empty x + in + let of_map m = StepMap.fold (fun k v acc -> (k, v) :: acc) m [] in + map (list (pair Path.step_t elt)) to_map of_map + + let update_t (elt : elt Type.t) : update Type.t = + let open Type in + variant "Node.update" (fun add remove -> function + | Add elt -> add elt | Remove -> remove) + |~ case1 "add" elt (fun elt -> Add elt) + |~ case0 "remove" Remove + |> sealv + + let v_t (elt : elt Type.t) : v Type.t = + let m = stepmap_t elt in + let um = stepmap_t (update_t elt) in + let open Type in + variant "Node.node" (fun map key value pruned portable_dirty -> function + | Map m -> map m + | Key (_, y) -> key y + | Value (_, v, m) -> value (v, m) + | Pruned h -> pruned h + | Portable_dirty (v, m) -> portable_dirty (v, m)) + |~ case1 "map" m (fun m -> Map m) + |~ case1 "key" P.Node.Key.t (fun _ -> assert false) + |~ case1 "value" (pair P.Node.Val.t (option um)) (fun _ -> assert false) + |~ case1 "pruned" hash_t (fun h -> Pruned h) + |~ case1 "portable_dirty" (pair portable_t um) (fun (v, m) -> + Portable_dirty (v, m)) + |> sealv + + let of_v ~env v = + let ptr, map, value = + match v with + | Map m -> (Ptr_none, Some m, None) + | Key (_, k) -> (Key k, None, None) + | Value (_, v, None) -> (Ptr_none, None, Some v) + | Value _ | Portable_dirty _ | Pruned _ -> (Ptr_none, None, None) + in + let findv_cache = None in + let info = { ptr; map; value; findv_cache; env } in + { v; info } + + let of_map m = of_v (Map m) + let of_key repo k = of_v (Key (repo, k)) + let of_value ?updates repo v = of_v (Value (repo, v, updates)) + let of_portable_dirty p updates = of_v (Portable_dirty (p, updates)) + let pruned h = of_v (Pruned h) + + let info_is_empty i = + i.map = None && i.value = None && i.findv_cache = None && i.ptr = Ptr_none + + let add_to_findv_cache t step v = + match t.info.findv_cache with + | None -> t.info.findv_cache <- Some (StepMap.singleton step v) + | Some m -> t.info.findv_cache <- Some (StepMap.add step v m) + + let clear_info_fields i = + if not (info_is_empty i) then ( + i.value <- None; + i.map <- None; + i.ptr <- Ptr_none; + i.findv_cache <- None) + + let rec clear_elt ~max_depth depth v = + match v with + | `Contents (c, _) -> if depth + 1 > max_depth then Contents.clear c + | `Node t -> clear ~max_depth (depth + 1) t + + and clear_info ~max_depth ~v depth i = + let clear _ v = clear_elt ~max_depth depth v in + let () = + match v with + | Value (_, _, Some um) -> + StepMap.iter + (fun k -> function Remove -> () | Add v -> clear k v) + um + | Value (_, _, None) | Map _ | Key _ | Portable_dirty _ | Pruned _ -> () + in + let () = + match (v, i.map) with + | Map m, _ | (Key _ | Value _ | Portable_dirty _ | Pruned _), Some m -> + StepMap.iter clear m + | (Key _ | Value _ | Portable_dirty _ | Pruned _), None -> () + in + let () = + match i.findv_cache with Some m -> StepMap.iter clear m | None -> () + in + if depth >= max_depth then clear_info_fields i + + and clear ~max_depth depth t = clear_info ~v:t.v ~max_depth depth t.info + + (* export t to the given repo and clear the cache *) + let export ?clear:(c = true) repo t k = + let ptr = t.info.ptr in + if c then clear_info_fields t.info; + match t.v with + | Key (repo', k) -> if repo != repo' then t.v <- Key (repo, k) + | Value _ | Map _ -> ( + match ptr with + | Ptr_none | Hash _ -> t.v <- Key (repo, k) + | Key k -> t.v <- Key (repo, k)) + | Portable_dirty _ | Pruned _ -> + (* The main export function never exports a pruned position. *) + assert false + + module Core_value + (N : Node.Generic_key.Core + with type step := step + and type hash := hash + and type metadata := metadata) + (To_elt : sig + type repo + + val t : env:Env.t -> repo -> N.value -> elt + end) = + struct + let to_map ~cache ~env repo t = + cnt.node_val_list <- cnt.node_val_list + 1; + let entries = N.seq ~cache t in + Seq.fold_left + (fun acc (k, v) -> StepMap.add k (To_elt.t ~env repo v) acc) + StepMap.empty entries + + (** Does [um] empties [v]? + + Gotcha: Some [Remove] entries in [um] might not be in [v]. *) + let is_empty_after_updates ~cache t um = + let any_add = + StepMap.to_seq um + |> Seq.exists (function _, Remove -> false | _, Add _ -> true) + in + if any_add then false + else + let val_is_empty = N.is_empty t in + if val_is_empty then true + else + let remove_count = StepMap.cardinal um in + if (not val_is_empty) && remove_count = 0 then false + else if N.length t > remove_count then false + else ( + (* Starting from this point the function is expensive, but there is + no alternative. *) + cnt.node_val_list <- cnt.node_val_list + 1; + let entries = N.seq ~cache t in + Seq.for_all (fun (step, _) -> StepMap.mem step um) entries) + + let findv ~cache ~env step node repo t = + match N.find ~cache t step with + | None -> None + | Some v -> + let tree = To_elt.t ~env repo v in + if cache then add_to_findv_cache node step tree; + Some tree + + let seq ~env ?offset ?length ~cache repo v = + cnt.node_val_list <- cnt.node_val_list + 1; + let seq = N.seq ?offset ?length ~cache v in + Seq.map (fun (k, v) -> (k, To_elt.t ~env repo v)) seq + end + + module Regular_value = + Core_value + (P.Node.Val) + (struct + type nonrec repo = repo + + let t ~env repo = function + | `Node k -> `Node (of_key ~env repo k) + | `Contents (k, m) -> `Contents (Contents.of_key ~env repo k, m) + end) + + module Portable_value = + Core_value + (P.Node_portable) + (struct + type repo = unit + + let t ~env () = function + | `Node h -> `Node (pruned ~env h) + | `Contents (h, m) -> `Contents (Contents.pruned ~env h, m) + end) + + (** This [Scan] module contains function that scan the content of [t.v] and + [t.info], looking for specific patterns. *) + module Scan = struct + let iter_hash t hit miss miss_arg = + match (t.v, t.info.ptr) with + | Key (_, k), _ -> hit (P.Node.Key.to_hash k) + | (Map _ | Value _ | Portable_dirty _), Key k -> + hit (P.Node.Key.to_hash k) + | Pruned h, _ -> hit h + | (Map _ | Value _ | Portable_dirty _), Hash h -> hit h + | (Map _ | Value _ | Portable_dirty _), Ptr_none -> miss t miss_arg + + let iter_key t hit miss miss_arg = + match (t.v, t.info.ptr) with + | Key (_, k), _ -> hit k + | (Map _ | Value _ | Portable_dirty _ | Pruned _), Key k -> hit k + | (Map _ | Value _ | Portable_dirty _ | Pruned _), (Hash _ | Ptr_none) + -> + miss t miss_arg + + let iter_map t hit miss miss_arg = + match (t.v, t.info.map) with + | (Key _ | Value _ | Portable_dirty _ | Pruned _), Some m -> hit m + | Map m, _ -> hit m + | (Key _ | Value _ | Portable_dirty _ | Pruned _), None -> + miss t miss_arg + + let iter_value t hit miss miss_arg = + match (t.v, t.info.value) with + | Value (_, v, None), None -> hit v + | (Map _ | Key _ | Value _ | Portable_dirty _ | Pruned _), Some v -> + hit v + | ( (Map _ | Key _ | Value (_, _, Some _) | Portable_dirty _ | Pruned _), + None ) -> + iter_hash t + (fun h -> + (* The need for [t], [miss] and [miss_arg] allocates a closure *) + match Env.find_node t.info.env h with + | None -> miss t miss_arg + | Some v -> hit v) + miss miss_arg + + let iter_portable t hit miss miss_arg = + match t.v with + | Pruned h -> ( + match Env.find_pnode t.info.env h with + | None -> miss t miss_arg + | Some v -> hit v) + | Map _ | Key _ | Value _ | Portable_dirty _ -> + (* No need to peek in [env]in these cases because [env] + is in practice expected to only hit on [Pruned]. *) + miss t miss_arg + + let iter_repo_key t hit miss miss_arg = + match (t.v, t.info.ptr) with + | Key (repo, k), _ -> hit repo k + | Value (repo, _, _), Key k -> hit repo k + | (Map _ | Portable_dirty _ | Pruned _ | Value _), _ -> miss t miss_arg + + let iter_repo_value t hit miss miss_arg = + match (t.v, t.info.value) with + | Value (repo, v, None), _ -> hit repo v + | (Value (repo, _, _) | Key (repo, _)), Some v -> hit repo v + | (Value (repo, _, _) | Key (repo, _)), None -> + iter_hash t + (fun h -> + match Env.find_node t.info.env h with + | None -> miss t miss_arg + | Some v -> hit repo v) + miss miss_arg + | (Map _ | Portable_dirty _ | Pruned _), _ -> miss t miss_arg + + type node = t + + (** An instance of [t] is expected to be the result of a chain of [to_*] + function calls. + + The [to_*] functions scan a [node] and look for a specific pattern. + The first function in the chain to match a pattern will return the + instance of [t] and ignore the rest of the chain. + + The functions in the chain should be carefuly ordered so that the + computation that follows is as quick as possible (e.g. if the goal is + to convert a [node] to hash, [to_hash] should be checked before + [to_map]). + + [cascade] may be used in order to build chains. *) + + type _ t = + | Hash : hash -> [> `hash ] t + | Map : map -> [> `map ] t + | Value : value -> [> `value ] t + | Value_dirty : (repo * value * updatemap) -> [> `value_dirty ] t + | Portable : portable -> [> `portable ] t + | Portable_dirty : (portable * updatemap) -> [> `portable_dirty ] t + | Pruned : hash -> [> `pruned ] t + | Repo_key : (repo * key) -> [> `repo_key ] t + | Repo_value : (repo * value) -> [> `repo_value ] t + | Any : [> `any ] t + + module View_kind = struct + type _ t = + | Hash : [> `hash ] t + | Map : [> `map ] t + | Value : [> `value ] t + | Value_dirty : [> `value_dirty ] t + | Portable : [> `portable ] t + | Portable_dirty : [> `portable_dirty ] t + | Pruned : [> `pruned ] t + | Repo_key : [> `repo_key ] t + | Repo_value : [> `repo_value ] t + | Any : [> `any ] t + end + + let to_hash t miss = iter_hash t (fun h -> Hash h) miss + let to_map t miss = iter_map t (fun m -> Map m) miss + let to_value t miss = iter_value t (fun v -> Value v) miss + let to_portable t miss = iter_portable t (fun v -> Portable v) miss + + let to_value_dirty t miss miss_arg = + match t.v with + | Value (repo, v, Some um) -> Value_dirty (repo, v, um) + | Map _ | Key _ | Value (_, _, None) | Portable_dirty _ | Pruned _ -> + miss t miss_arg + + let to_portable_dirty t miss miss_arg = + match t.v with + | Portable_dirty (v, um) -> Portable_dirty (v, um) + | Map _ | Key _ | Value _ | Pruned _ -> miss t miss_arg + + let to_pruned t miss miss_arg = + match t.v with + | Pruned h -> Pruned h + | Map _ | Key _ | Value _ | Portable_dirty _ -> miss t miss_arg + + let to_repo_key t miss miss_arg = + iter_repo_key t (fun repo k -> Repo_key (repo, k)) miss miss_arg + + let to_repo_value t miss miss_arg = + iter_repo_value t (fun repo v -> Repo_value (repo, v)) miss miss_arg + + let rec cascade : type k. node -> k View_kind.t list -> k t = + fun t -> function + | [] -> + (* The declared cascade doesn't cover all cases *) + assert false + | x :: xs -> ( + match x with + | Hash -> to_hash t cascade xs + | Map -> to_map t cascade xs + | Value -> to_value t cascade xs + | Value_dirty -> to_value_dirty t cascade xs + | Portable -> to_portable t cascade xs + | Portable_dirty -> to_portable_dirty t cascade xs + | Pruned -> to_pruned t cascade xs + | Repo_key -> to_repo_key t cascade xs + | Repo_value -> to_repo_value t cascade xs + | Any -> Any) + end + + let get_none _ () = None + let cached_hash t = Scan.iter_hash t Option.some get_none () + let cached_key t = Scan.iter_key t Option.some get_none () + let cached_map t = Scan.iter_map t Option.some get_none () + let cached_value t = Scan.iter_value t Option.some get_none () + let cached_portable t = Scan.iter_portable t Option.some get_none () + + let key t = + match t.v with + | Key (_, k) -> Some k + | Map _ | Value _ | Portable_dirty _ | Pruned _ -> None + + (* When computing hashes of nodes, we try to use [P.Node.Val.t] as a + pre-image if possible so that this intermediate value can be cached + within [t.info.value] (in case it is about to be written to the backend). + + This is only possible if all of the child pointers have pre-existing + keys, otherwise we must convert to portable nodes as a fallback. *) + type hash_preimage = Node of P.Node.Val.t | Pnode of Portable.t + type node_value = P.Node.Val.value + type pnode_value = Portable.value + + type hash_preimage_value = + | Node_value of node_value + | Pnode_value of pnode_value + + let weaken_value : node_value -> pnode_value = function + | `Contents (key, m) -> `Contents (P.Contents.Key.to_hash key, m) + | `Node key -> `Node (P.Node.Key.to_hash key) + + let rec hash : type a. cache:bool -> t -> (hash -> a) -> a = + fun ~cache t k -> + let a_of_hashable hash v = + cnt.node_hash <- cnt.node_hash + 1; + let hash = hash v in + assert (t.info.ptr = Ptr_none); + if cache then t.info.ptr <- Hash hash; + k hash + in + match + (Scan.cascade t [ Hash; Value; Value_dirty; Portable_dirty; Map ] + : [ `hash | `value | `value_dirty | `portable_dirty | `map ] Scan.t) + with + | Hash h -> k h + | Value v -> a_of_hashable P.Node.Val.hash_exn v + | Value_dirty (_repo, v, um) -> + hash_preimage_of_updates ~cache t (Node v) um (function + | Node x -> a_of_hashable P.Node.Val.hash_exn x + | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) + | Portable_dirty (p, um) -> + hash_preimage_of_updates ~cache t (Pnode p) um (function + | Node x -> a_of_hashable P.Node.Val.hash_exn x + | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) + | Map m -> + hash_preimage_of_map ~cache t m (function + | Node x -> a_of_hashable P.Node.Val.hash_exn x + | Pnode x -> a_of_hashable P.Node_portable.hash_exn x) + + and hash_preimage_of_map : + type r. cache:bool -> t -> map -> (hash_preimage, r) cont = + fun ~cache t map k -> + cnt.node_val_v <- cnt.node_val_v + 1; + let bindings = StepMap.to_seq map in + let must_build_portable_node = + bindings + |> Seq.exists (fun (_, v) -> + match v with + | `Node n -> Option.is_none (cached_key n) + | `Contents (c, _) -> Option.is_none (Contents.cached_key c)) + in + if must_build_portable_node then + let pnode = + bindings + |> Seq.map (fun (step, v) -> + match v with + | `Contents (c, m) -> (step, `Contents (Contents.hash c, m)) + | `Node n -> hash ~cache n (fun k -> (step, `Node k))) + |> Portable.of_seq + in + k (Pnode pnode) + else + let node = + bindings + |> Seq.map (fun (step, v) -> + match v with + | `Contents (c, m) -> ( + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + (* We checked that all child keys are cached above *) + assert false) + | `Node n -> ( + match cached_key n with + | Some k -> (step, `Node k) + | None -> + (* We checked that all child keys are cached above *) + assert false)) + |> P.Node.Val.of_seq + in + if cache then t.info.value <- Some node; + k (Node node) + + and hash_preimage_value_of_elt : + type r. cache:bool -> elt -> (hash_preimage_value, r) cont = + fun ~cache e k -> + match e with + | `Contents (c, m) -> ( + match Contents.key c with + | Some key -> k (Node_value (`Contents (key, m))) + | None -> k (Pnode_value (`Contents (Contents.hash c, m)))) + | `Node n -> ( + match key n with + | Some key -> k (Node_value (`Node key)) + | None -> hash ~cache n (fun hash -> k (Pnode_value (`Node hash)))) + + and hash_preimage_of_updates : + type r. + cache:bool -> t -> hash_preimage -> updatemap -> (hash_preimage, r) cont + = + fun ~cache t v updates k -> + let updates = StepMap.bindings updates in + let rec aux acc = function + | [] -> + (if cache then + match acc with Node n -> t.info.value <- Some n | Pnode _ -> ()); + k acc + | (k, Add e) :: rest -> + hash_preimage_value_of_elt ~cache e (fun e -> + let acc = + match (acc, e) with + | Node n, Node_value v -> Node (P.Node.Val.add n k v) + | Node n, Pnode_value v -> + Pnode (Portable.add (Portable.of_node n) k v) + | Pnode n, Node_value v -> + Pnode (Portable.add n k (weaken_value v)) + | Pnode n, Pnode_value v -> Pnode (Portable.add n k v) + in + aux acc rest) + | (k, Remove) :: rest -> + let acc = + match acc with + | Node n -> Node (P.Node.Val.remove n k) + | Pnode n -> Pnode (Portable.remove n k) + in + aux acc rest + in + aux v updates + + let hash ~cache k = hash ~cache k (fun x -> x) + + let value_of_key ~cache t repo k = + match cached_value t with + | Some v -> ok v + | None -> ( + cnt.node_find <- cnt.node_find + 1; + let+ v_opt = P.Node.find (P.Repo.node_t repo) k in + let h = P.Node.Key.to_hash k in + let v_opt = Option.map (Env.add_node_from_store t.info.env h) v_opt in + match v_opt with + | None -> err_dangling_hash h + | Some v -> + if cache then t.info.value <- v_opt; + Ok v) + + let to_value ~cache t = + match + (Scan.cascade t [ Value; Repo_key; Any ] + : [ `value | `repo_key | `any ] Scan.t) + with + | Value v -> ok v + | Repo_key (repo, k) -> value_of_key ~cache t repo k + | Any -> ( + match t.v with + | Key _ | Value (_, _, None) -> assert false + | Pruned h -> err_pruned_hash h |> Lwt.return + | Portable_dirty _ -> err_portable_value |> Lwt.return + | Map _ | Value (_, _, Some _) -> + invalid_arg + "Tree.Node.to_value: the supplied node has not been written to \ + disk. Either export it or convert it to a portable value \ + instead.") + + let to_portable_value_aux ~cache ~value_of_key ~return ~bind:( let* ) t = + let ok x = return (Ok x) in + match + (Scan.cascade t + [ + Portable; Value; Repo_key; Portable_dirty; Value_dirty; Map; Pruned; + ] + : [ `portable + | `value + | `repo_key + | `portable_dirty + | `value_dirty + | `map + | `pruned ] + Scan.t) + with + | Portable p -> ok p + | Value v -> ok (P.Node_portable.of_node v) + | Portable_dirty (p, um) -> + hash_preimage_of_updates ~cache t (Pnode p) um (function + | Node _ -> assert false + | Pnode x -> ok x) + | Repo_key (repo, k) -> + let* value_res = value_of_key ~cache t repo k in + Result.map P.Node_portable.of_node value_res |> return + | Value_dirty (_repo, v, um) -> + hash_preimage_of_updates ~cache t (Node v) um (function + | Node x -> ok (Portable.of_node x) + | Pnode x -> ok x) + | Map m -> + hash_preimage_of_map ~cache t m (function + | Node x -> ok (Portable.of_node x) + | Pnode x -> ok x) + | Pruned h -> err_pruned_hash h |> return + + let to_portable_value = + to_portable_value_aux ~value_of_key ~return:Lwt.return ~bind:Lwt.bind + + let to_map ~cache t = + let of_maps m updates = + let m = + match updates with + | None -> m + | Some updates -> + StepMap.stdlib_merge + (fun _ left right -> + match (left, right) with + | None, None -> assert false + | (Some _ as v), None -> v + | _, Some (Add v) -> Some v + | _, Some Remove -> None) + m updates + in + if cache then t.info.map <- Some m; + m + in + let of_value repo v um = + let env = t.info.env in + let m = Regular_value.to_map ~env ~cache repo v in + of_maps m um + in + let of_portable_value v um = + let env = t.info.env in + let m = Portable_value.to_map ~env ~cache () v in + of_maps m um + in + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> ok m + | Repo_value (repo, v) -> ok (of_value repo v None) + | Repo_key (repo, k) -> ( + value_of_key ~cache t repo k >|= function + | Error _ as e -> e + | Ok v -> Ok (of_value repo v None)) + | Value_dirty (repo, v, um) -> ok (of_value repo v (Some um)) + | Portable p -> ok (of_portable_value p None) + | Portable_dirty (p, um) -> ok (of_portable_value p (Some um)) + | Pruned h -> err_pruned_hash h |> Lwt.return + + let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = + x1 == x2 || (Contents.equal c1 c2 && equal_metadata m1 m2) + + let rec elt_equal (x : elt) (y : elt) = + x == y + || + match (x, y) with + | `Contents x, `Contents y -> contents_equal x y + | `Node x, `Node y -> equal x y + | _ -> false + + and map_equal (x : map) (y : map) = StepMap.equal elt_equal x y + + and equal (x : t) (y : t) = + x == y + || + match (cached_hash x, cached_hash y) with + | Some x, Some y -> equal_hash x y + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> equal_value x y + | _ -> ( + match (cached_portable x, cached_portable y) with + | Some x, Some y -> equal_portable x y + | _ -> ( + match (cached_map x, cached_map y) with + | Some x, Some y -> map_equal x y + | _ -> equal_hash (hash ~cache:true x) (hash ~cache:true y)))) + + (* same as [equal] but do not compare in-memory maps + recursively. *) + let maybe_equal (x : t) (y : t) = + if x == y then True + else + match (cached_hash x, cached_hash y) with + | Some x, Some y -> if equal_hash x y then True else False + | _ -> ( + match (cached_value x, cached_value y) with + | Some x, Some y -> if equal_value x y then True else False + | _ -> ( + match (cached_portable x, cached_portable y) with + | Some x, Some y -> if equal_portable x y then True else False + | _ -> Maybe)) + + let empty () = of_map StepMap.empty ~env:(Env.empty ()) + let empty_hash = hash ~cache:false (empty ()) + let singleton k v = of_map (StepMap.singleton k v) + + let length ~cache t = + match + (Scan.cascade t + [ + Map; Value; Portable; Repo_key; Value_dirty; Portable_dirty; Pruned; + ] + : [ `map + | `value + | `portable + | `repo_key + | `value_dirty + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> StepMap.cardinal m |> Lwt.return + | Value v -> P.Node.Val.length v |> Lwt.return + | Portable p -> P.Node_portable.length p |> Lwt.return + | Repo_key (repo, k) -> + value_of_key ~cache t repo k >|= get_ok "length" >|= P.Node.Val.length + | Value_dirty (_repo, v, um) -> + hash_preimage_of_updates ~cache t (Node v) um (function + | Node x -> P.Node.Val.length x |> Lwt.return + | Pnode x -> P.Node_portable.length x |> Lwt.return) + | Portable_dirty (p, um) -> + hash_preimage_of_updates ~cache t (Pnode p) um (function + | Node _ -> assert false + | Pnode x -> P.Node_portable.length x |> Lwt.return) + | Pruned h -> pruned_hash_exn "length" h + + let is_empty ~cache t = + match + (Scan.cascade t + [ Map; Value; Portable; Hash; Value_dirty; Portable_dirty ] + : [ `map + | `value + | `portable + | `hash + | `value_dirty + | `portable_dirty ] + Scan.t) + with + | Map m -> StepMap.is_empty m + | Value v -> P.Node.Val.is_empty v + | Portable p -> P.Node_portable.is_empty p + | Hash h -> equal_hash h empty_hash + | Value_dirty (_repo, v, um) -> + Regular_value.is_empty_after_updates ~cache v um + | Portable_dirty (p, um) -> + Portable_value.is_empty_after_updates ~cache p um + + let findv_aux ~cache ~value_of_key ~return ~bind:( let* ) ctx t step = + let of_map m = try Some (StepMap.find step m) with Not_found -> None in + let of_value = Regular_value.findv ~cache ~env:t.info.env step t in + let of_portable = Portable_value.findv ~cache ~env:t.info.env step t () in + let of_t () = + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> return (of_map m) + | Repo_value (repo, v) -> return (of_value repo v) + | Repo_key (repo, k) -> + let* v = value_of_key ~cache t repo k in + let v = get_ok ctx v in + return (of_value repo v) + | Value_dirty (repo, v, um) -> ( + match StepMap.find_opt step um with + | Some (Add v) -> return (Some v) + | Some Remove -> return None + | None -> return (of_value repo v)) + | Portable p -> return (of_portable p) + | Portable_dirty (p, um) -> ( + match StepMap.find_opt step um with + | Some (Add v) -> return (Some v) + | Some Remove -> return None + | None -> return (of_portable p)) + | Pruned h -> pruned_hash_exn ctx h + in + match t.info.findv_cache with + | None -> of_t () + | Some m -> ( + match of_map m with None -> of_t () | Some _ as r -> return r) + + let findv = findv_aux ~value_of_key ~return:Lwt.return ~bind:Lwt.bind + + let seq_of_map ?(offset = 0) ?length m : (step * elt) Seq.t = + let take seq = + match length with None -> seq | Some n -> Seq.take n seq + in + StepMap.to_seq m |> Seq.drop offset |> take + + let seq ?offset ?length ~cache t : (step * elt) Seq.t or_error Lwt.t = + let env = t.info.env in + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> ok (seq_of_map ?offset ?length m) + | Repo_value (repo, v) -> + ok (Regular_value.seq ~env ?offset ?length ~cache repo v) + | Repo_key (repo, k) -> ( + value_of_key ~cache t repo k >>= function + | Error _ as e -> Lwt.return e + | Ok v -> ok (Regular_value.seq ~env ?offset ?length ~cache repo v)) + | Value_dirty _ | Portable_dirty _ -> ( + to_map ~cache t >>= function + | Error _ as e -> Lwt.return e + | Ok m -> ok (seq_of_map ?offset ?length m)) + | Portable p -> ok (Portable_value.seq ~env ?offset ?length ~cache () p) + | Pruned h -> err_pruned_hash h |> Lwt.return + + let bindings ~cache t = + (* XXX: If [t] is value, no need to [to_map]. Let's remove and inline + this into Tree.entries. *) + to_map ~cache t >|= function + | Error _ as e -> e + | Ok m -> Ok (StepMap.bindings m) + + let seq_of_updates updates value_bindings = + (* This operation can be costly for large updates. *) + if StepMap.is_empty updates then + (* Short-circuit return if we have no more updates to apply. *) + value_bindings + else + let value_bindings = + Seq.filter (fun (s, _) -> not (StepMap.mem s updates)) value_bindings + in + let updates = + StepMap.to_seq updates + |> Seq.filter_map (fun (s, elt) -> + match elt with Remove -> None | Add e -> Some (s, e)) + in + Seq.append value_bindings updates + + type ('v, 'acc, 'r) cps_folder = + path:Path.t -> 'acc -> int -> 'v -> ('acc, 'r) cont_lwt + (** A ('val, 'acc, 'r) cps_folder is a CPS, threaded fold function over + values of type ['v] producing an accumulator of type ['acc]. *) + + let fold : + type acc. + order:[ `Sorted | `Undefined | `Random of Random.State.t ] -> + force:acc force -> + cache:bool -> + uniq:uniq -> + pre:(acc, step list) folder option -> + post:(acc, step list) folder option -> + path:Path.t -> + ?depth:depth -> + node:(acc, _) folder -> + contents:(acc, contents) folder -> + tree:(acc, _) folder -> + t -> + acc -> + acc Lwt.t = + fun ~order ~force ~cache ~uniq ~pre ~post ~path ?depth ~node ~contents + ~tree t acc -> + let env = t.info.env in + let marks = + match uniq with + | `False -> dummy_marks + | `True -> empty_marks () + | `Marks n -> n + in + let pre path bindings acc = + match pre with + | None -> Lwt.return acc + | Some pre -> + let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in + pre path s acc + in + let post path bindings acc = + match post with + | None -> Lwt.return acc + | Some post -> + let s = Seq.fold_left (fun acc (s, _) -> s :: acc) [] bindings in + post path s acc + in + let rec aux : type r. (t, acc, r) cps_folder = + fun ~path acc d t k -> + let apply acc = node path t acc >>= tree path (`Node t) in + let next acc = + match force with + | `True -> ( + match order with + | `Random state -> + let* m = to_map ~cache t >|= get_ok "fold" in + let arr = StepMap.to_array m in + let () = shuffle state arr in + let s = Array.to_seq arr in + (seq [@tailcall]) ~path acc d s k + | `Sorted -> + let* m = to_map ~cache t >|= get_ok "fold" in + (map [@tailcall]) ~path acc d (Some m) k + | `Undefined -> ( + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> (map [@tailcall]) ~path acc d (Some m) k + | Repo_value (repo, v) -> + (value [@tailcall]) ~path acc d (repo, v, None) k + | Repo_key (repo, _key) -> + let* v = to_value ~cache t >|= get_ok "fold" in + (value [@tailcall]) ~path acc d (repo, v, None) k + | Value_dirty (repo, v, um) -> + (value [@tailcall]) ~path acc d (repo, v, Some um) k + | Portable p -> (portable [@tailcall]) ~path acc d (p, None) k + | Portable_dirty (p, um) -> + (portable [@tailcall]) ~path acc d (p, Some um) k + | Pruned h -> pruned_hash_exn "fold" h)) + | `False skip -> ( + match cached_map t with + | Some n -> ( + match order with + | `Sorted | `Undefined -> + (map [@tailcall]) ~path acc d (Some n) k + | `Random state -> + let arr = StepMap.to_array n in + shuffle state arr; + let s = Array.to_seq arr in + (seq [@tailcall]) ~path acc d s k) + | None -> + (* XXX: That node is skipped if is is of tag Value *) + skip path acc >>= k) + in + match depth with + | None -> apply acc >>= next + | Some (`Eq depth) -> if d < depth then next acc else apply acc >>= k + | Some (`Le depth) -> + if d < depth then apply acc >>= next else apply acc >>= k + | Some (`Lt depth) -> + if d < depth - 1 then apply acc >>= next else apply acc >>= k + | Some (`Ge depth) -> if d < depth then next acc else apply acc >>= next + | Some (`Gt depth) -> + if d <= depth then next acc else apply acc >>= next + and aux_uniq : type r. (t, acc, r) cps_folder = + fun ~path acc d t k -> + if uniq = `False then (aux [@tailcall]) ~path acc d t k + else + let h = hash ~cache t in + match Hashes.add marks h with + | `Duplicate -> k acc + | `Ok -> (aux [@tailcall]) ~path acc d t k + and step : type r. (step * elt, acc, r) cps_folder = + fun ~path acc d (s, v) k -> + let path = Path.rcons path s in + match v with + | `Node n -> (aux_uniq [@tailcall]) ~path acc (d + 1) n k + | `Contents c -> ( + let apply () = + let tree path = tree path (`Contents c) in + Contents.fold ~force ~cache ~path contents tree (fst c) acc >>= k + in + match depth with + | None -> apply () + | Some (`Eq depth) -> if d = depth - 1 then apply () else k acc + | Some (`Le depth) -> if d < depth then apply () else k acc + | Some (`Lt depth) -> if d < depth - 1 then apply () else k acc + | Some (`Ge depth) -> if d >= depth - 1 then apply () else k acc + | Some (`Gt depth) -> if d >= depth then apply () else k acc) + and steps : type r. ((step * elt) Seq.t, acc, r) cps_folder = + fun ~path acc d s k -> + match s () with + | Seq.Nil -> k acc + | Seq.Cons (h, t) -> + (step [@tailcall]) ~path acc d h (fun acc -> + (steps [@tailcall]) ~path acc d t k) + and map : type r. (map option, acc, r) cps_folder = + fun ~path acc d m k -> + match m with + | None -> k acc + | Some m -> + let bindings = StepMap.to_seq m in + seq ~path acc d bindings k + and value : type r. (repo * value * updatemap option, acc, r) cps_folder = + fun ~path acc d (repo, v, updates) k -> + let bindings = Regular_value.seq ~env ~cache repo v in + let bindings = + match updates with + | None -> bindings + | Some updates -> seq_of_updates updates bindings + in + seq ~path acc d bindings k + and portable : type r. (portable * updatemap option, acc, r) cps_folder = + fun ~path acc d (v, updates) k -> + let bindings = Portable_value.seq ~env ~cache () v in + let bindings = + match updates with + | None -> bindings + | Some updates -> seq_of_updates updates bindings + in + seq ~path acc d bindings k + and seq : type r. ((step * elt) Seq.t, acc, r) cps_folder = + fun ~path acc d bindings k -> + let* acc = pre path bindings acc in + (steps [@tailcall]) ~path acc d bindings (fun acc -> + post path bindings acc >>= k) + in + aux_uniq ~path acc 0 t Lwt.return + + let update t step up = + let env = t.info.env in + let of_map m = + let m' = + match up with + | Remove -> StepMap.remove step m + | Add v -> StepMap.add step v m + in + if m == m' then t else of_map ~env m' + in + let of_value repo n updates = + let updates' = StepMap.add step up updates in + if updates == updates' then t + else of_value ~env repo n ~updates:updates' + in + let of_portable n updates = + let updates' = StepMap.add step up updates in + if updates == updates' then t else of_portable_dirty ~env n updates' + in + match + (Scan.cascade t + [ + Map; + Repo_value; + Repo_key; + Value_dirty; + Portable; + Portable_dirty; + Pruned; + ] + : [ `map + | `repo_key + | `repo_value + | `value_dirty + | `portable + | `portable_dirty + | `pruned ] + Scan.t) + with + | Map m -> Lwt.return (of_map m) + | Repo_value (repo, v) -> Lwt.return (of_value repo v StepMap.empty) + | Repo_key (repo, k) -> + let+ v = value_of_key ~cache:true t repo k >|= get_ok "update" in + of_value repo v StepMap.empty + | Value_dirty (repo, v, um) -> Lwt.return (of_value repo v um) + | Portable p -> Lwt.return (of_portable p StepMap.empty) + | Portable_dirty (p, um) -> Lwt.return (of_portable p um) + | Pruned h -> pruned_hash_exn "update" h + + let remove t step = update t step Remove + let add t step v = update t step (Add v) + + let compare (x : t) (y : t) = + if x == y then 0 + else compare_hash (hash ~cache:true x) (hash ~cache:true y) + + let t node = + let of_v v = of_v ~env:(Env.empty ()) v in + Type.map ~equal ~compare node of_v (fun t -> t.v) + + let _, t = + Type.mu2 (fun _ y -> + let elt = elt_t y in + let v = v_t elt in + let t = t v in + (v, t)) + + let elt_t = elt_t t + let dump = Type.pp_dump t + + let rec merge : type a. (t Merge.t -> a) -> a = + fun k -> + let f ~old x y = + let old = + Merge.bind_promise old (fun old () -> + let+ m = to_map ~cache:true old >|= Option.of_result in + Ok (Some m)) + in + match merge_env x.info.env y.info.env with + | Error _ as e -> Lwt.return e + | Ok env -> ( + let* x = to_map ~cache:true x >|= Option.of_result in + let* y = to_map ~cache:true y >|= Option.of_result in + let m = + StepMap.merge elt_t (fun _step -> + (merge_elt [@tailcall]) Merge.option) + in + Merge.(f @@ option m) ~old x y >|= function + | Ok (Some map) -> Ok (of_map ~env map) + | Ok None -> Error (`Conflict "empty map") + | Error _ as e -> e) + in + k (Merge.v t f) + + and merge_elt : type r. (elt Merge.t, r) cont = + fun k -> + let open Merge.Infix in + let f : elt Merge.f = + fun ~old x y -> + match (x, y) with + | `Contents (x, cx), `Contents (y, cy) -> + let mold = + Merge.bind_promise old (fun old () -> + match old with + | `Contents (_, m) -> ok (Some m) + | `Node _ -> ok None) + in + Merge.(f Metadata.merge) ~old:mold cx cy >>=* fun m -> + let old = + Merge.bind_promise old (fun old () -> + match old with + | `Contents (c, _) -> ok (Some c) + | `Node _ -> ok None) + in + Merge.(f Contents.merge) ~old x y >>=* fun c -> + Merge.ok (`Contents (c, m)) + | `Node x, `Node y -> + (merge [@tailcall]) (fun m -> + let old = + Merge.bind_promise old (fun old () -> + match old with + | `Contents _ -> ok None + | `Node n -> ok (Some n)) + in + Merge.(f m ~old x y) >>=* fun n -> Merge.ok (`Node n)) + | _ -> Merge.conflict "add/add values" + in + k (Merge.seq [ Merge.default elt_t; Merge.v elt_t f ]) + + let merge_elt = merge_elt (fun x -> x) + end + + type node = Node.t [@@deriving irmin ~pp] + type node_key = Node.key [@@deriving irmin ~pp] + type contents_key = Contents.key [@@deriving irmin ~pp] + + type kinded_key = [ `Contents of Contents.key * metadata | `Node of Node.key ] + [@@deriving irmin] + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin ~equal] + + type t = [ `Node of node | `Contents of Contents.t * Metadata.t ] + [@@deriving irmin] + + let to_backend_node n = + Node.to_value ~cache:true n >|= get_ok "to_backend_node" + + let to_backend_portable_node n = + Node.to_portable_value ~cache:true n >|= get_ok "to_backend_portable_node" + + let of_backend_node repo n = + let env = Env.empty () in + Node.of_value ~env repo n + + let dump ppf = function + | `Node n -> Fmt.pf ppf "node: %a" Node.dump n + | `Contents (c, _) -> Fmt.pf ppf "contents: %a" (Type.pp Contents.t) c + + let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = + x1 == x2 + || (c1 == c2 && m1 == m2) + || (Contents.equal c1 c2 && equal_metadata m1 m2) + + let equal (x : t) (y : t) = + x == y + || + match (x, y) with + | `Node x, `Node y -> Node.equal x y + | `Contents x, `Contents y -> contents_equal x y + | `Node _, `Contents _ | `Contents _, `Node _ -> false + + let is_empty = function + | `Node n -> Node.is_empty ~cache:true n + | `Contents _ -> false + + type elt = [ `Node of node | `Contents of contents * metadata ] + + let of_node n = `Node n + + let of_contents ?(metadata = Metadata.default) c = + let env = Env.empty () in + let c = Contents.of_value ~env c in + `Contents (c, metadata) + + let v : elt -> t = function + | `Contents (c, metadata) -> of_contents ~metadata c + | `Node n -> `Node n + + let pruned_with_env ~env = function + | `Contents (h, meta) -> `Contents (Contents.pruned ~env h, meta) + | `Node h -> `Node (Node.pruned ~env h) + + let pruned h = + let env = Env.empty () in + pruned_with_env ~env h + + let destruct x = x + + let clear ?(depth = 0) = function + | `Node n -> Node.clear ~max_depth:depth 0 n + | `Contents _ -> () + + let sub ~cache ctx t path = + let rec aux node path = + match Path.decons path with + | None -> Lwt.return_some node + | Some (h, p) -> ( + Node.findv ~cache ctx node h >>= function + | None | Some (`Contents _) -> Lwt.return_none + | Some (`Node n) -> (aux [@tailcall]) n p) + in + match t with + | `Node n -> (aux [@tailcall]) n path + | `Contents _ -> Lwt.return_none + + let find_tree (t : t) path = + let cache = true in + [%log.debug "Tree.find_tree %a" pp_path path]; + match (t, Path.rdecons path) with + | v, None -> Lwt.return_some v + | _, Some (path, file) -> ( + sub ~cache "find_tree.sub" t path >>= function + | None -> Lwt.return_none + | Some n -> Node.findv ~cache "find_tree.findv" n file) + + let id _ _ acc = Lwt.return acc + + let fold ?(order = `Sorted) ?(force = `True) ?(cache = false) ?(uniq = `False) + ?pre ?post ?depth ?(contents = id) ?(node = id) ?(tree = id) (t : t) acc = + match t with + | `Contents (c, _) as c' -> + let tree path = tree path c' in + Contents.fold ~force ~cache ~path:Path.empty contents tree c acc + | `Node n -> + Node.fold ~order ~force ~cache ~uniq ~pre ~post ~path:Path.empty ?depth + ~contents ~node ~tree n acc + + type stats = { + nodes : int; + leafs : int; + skips : int; + depth : int; + width : int; + } + [@@deriving irmin] + + let empty_stats = { nodes = 0; leafs = 0; skips = 0; depth = 0; width = 0 } + let incr_nodes s = { s with nodes = s.nodes + 1 } + let incr_leafs s = { s with leafs = s.leafs + 1 } + let incr_skips s = { s with skips = s.skips + 1 } + + let set_depth p s = + let n_depth = List.length (Path.map p (fun _ -> ())) in + let depth = max n_depth s.depth in + { s with depth } + + let set_width childs s = + let width = max s.width (List.length childs) in + { s with width } + + let err_not_found n k = + Fmt.kstr invalid_arg "Irmin.Tree.%s: %a not found" n pp_path k + + let get_tree (t : t) path = + find_tree t path >|= function + | None -> err_not_found "get_tree" path + | Some v -> v + + let find_all t k = + find_tree t k >>= function + | None | Some (`Node _) -> Lwt.return_none + | Some (`Contents (c, m)) -> + let+ c = Contents.to_value ~cache:true c in + Some (get_ok "find_all" c, m) + + let find t k = + find_all t k >|= function None -> None | Some (c, _) -> Some c + + let get_all t k = + find_all t k >>= function + | None -> err_not_found "get" k + | Some v -> Lwt.return v + + let get t k = get_all t k >|= fun (c, _) -> c + let mem t k = find t k >|= function None -> false | _ -> true + let mem_tree t k = find_tree t k >|= function None -> false | _ -> true + + let kind t path = + let cache = true in + [%log.debug "Tree.kind %a" pp_path path]; + match (t, Path.rdecons path) with + | `Contents _, None -> Lwt.return_some `Contents + | `Node _, None -> Lwt.return_some `Node + | _, Some (dir, file) -> ( + sub ~cache "kind.sub" t dir >>= function + | None -> Lwt.return_none + | Some m -> ( + Node.findv ~cache "kind.findv" m file >>= function + | None -> Lwt.return_none + | Some (`Contents _) -> Lwt.return_some `Contents + | Some (`Node _) -> Lwt.return_some `Node)) + + let length t ?(cache = true) path = + [%log.debug "Tree.length %a" pp_path path]; + sub ~cache "length" t path >>= function + | None -> Lwt.return 0 + | Some n -> Node.length ~cache:true n + + let seq t ?offset ?length ?(cache = true) path = + [%log.debug "Tree.seq %a" pp_path path]; + sub ~cache "seq.sub" t path >>= function + | None -> Lwt.return Seq.empty + | Some n -> Node.seq ?offset ?length ~cache n >|= get_ok "seq" + + let list t ?offset ?length ?(cache = true) path = + seq t ?offset ?length ~cache path >|= List.of_seq + + let empty () = `Node (Node.empty ()) + + let singleton k ?(metadata = Metadata.default) c = + [%log.debug "Tree.singleton %a" pp_path k]; + let env = Env.empty () in + let base_tree = `Contents (Contents.of_value ~env c, metadata) in + Path.fold_right k + ~f:(fun step child -> `Node (Node.singleton ~env step child)) + ~init:base_tree + + (** During recursive updates, we keep track of whether or not we've made a + modification in order to avoid unnecessary allocations of identical tree + objects. *) + type 'a updated = Changed of 'a | Unchanged + + let maybe_equal (x : t) (y : t) = + if x == y then True + else + match (x, y) with + | `Node x, `Node y -> Node.maybe_equal x y + | _ -> if equal x y then True else False + + let get_env = function + | `Node n -> n.Node.info.env + | `Contents (c, _) -> c.Contents.info.env + + let update_tree ~cache ~f_might_return_empty_node ~f root_tree path = + (* User-introduced empty nodes will be removed immediately if necessary. *) + let prune_empty : node -> bool = + if not f_might_return_empty_node then Fun.const false + else Node.is_empty ~cache + in + match Path.rdecons path with + | None -> ( + let empty_tree = + match is_empty root_tree with + | true -> root_tree + | false -> `Node (Node.empty ()) + in + f (Some root_tree) >>= function + (* Here we consider "deleting" a root contents value or node to consist + of changing it to an empty node. Note that this introduces + sensitivity to ordering of subtree operations: updating in a subtree + and adding the subtree are not necessarily commutative. *) + | None -> Lwt.return empty_tree + | Some (`Node _ as new_root) -> ( + match maybe_equal root_tree new_root with + | True -> Lwt.return root_tree + | Maybe | False -> Lwt.return new_root) + | Some (`Contents c' as new_root) -> ( + match root_tree with + | `Contents c when contents_equal c c' -> Lwt.return root_tree + | _ -> Lwt.return new_root)) + | Some (path, file) -> ( + let rec aux : type r. path -> node -> (node updated, r) cont_lwt = + fun path parent_node k -> + let changed n = k (Changed n) in + match Path.decons path with + | None -> ( + let with_new_child t = Node.add parent_node file t >>= changed in + let* old_binding = + Node.findv ~cache "update_tree.findv" parent_node file + in + let* new_binding = f old_binding in + match (old_binding, new_binding) with + | None, None -> k Unchanged + | None, Some (`Contents _ as t) -> with_new_child t + | None, Some (`Node n as t) -> ( + match prune_empty n with + | true -> k Unchanged + | false -> with_new_child t) + | Some _, None -> Node.remove parent_node file >>= changed + | Some old_value, Some (`Node n as t) -> ( + match prune_empty n with + | true -> Node.remove parent_node file >>= changed + | false -> ( + match maybe_equal old_value t with + | True -> k Unchanged + | Maybe | False -> with_new_child t)) + | Some (`Contents c), Some (`Contents c' as t) -> ( + match contents_equal c c' with + | true -> k Unchanged + | false -> with_new_child t) + | Some (`Node _), Some (`Contents _ as t) -> with_new_child t) + | Some (step, key_suffix) -> + let* old_binding = + Node.findv ~cache "update_tree.findv" parent_node step + in + let to_recurse = + match old_binding with + | Some (`Node child) -> child + | None | Some (`Contents _) -> Node.empty () + in + (aux [@tailcall]) key_suffix to_recurse (function + | Unchanged -> + (* This includes [remove]s in an empty node, in which case we + want to avoid adding a binding anyway. *) + k Unchanged + | Changed child -> ( + match Node.is_empty ~cache child with + | true -> + (* A [remove] has emptied previously non-empty child with + binding [h], so we remove the binding. *) + Node.remove parent_node step >>= changed + | false -> + Node.add parent_node step (`Node child) >>= changed)) + in + let top_node = + match root_tree with `Node n -> n | `Contents _ -> Node.empty () + in + aux path top_node @@ function + | Unchanged -> Lwt.return root_tree + | Changed node -> + Env.copy ~into:node.info.env (get_env root_tree); + Lwt.return (`Node node)) + + let update t k ?(metadata = Metadata.default) f = + let cache = true in + [%log.debug "Tree.update %a" pp_path k]; + update_tree ~cache t k ~f_might_return_empty_node:false ~f:(fun t -> + let+ old_contents = + match t with + | Some (`Node _) | None -> Lwt.return_none + | Some (`Contents (c, _)) -> + let+ c = Contents.to_value ~cache c in + Some (get_ok "update" c) + in + match f old_contents with + | None -> None + | Some c -> of_contents ~metadata c |> Option.some) + + let add t k ?(metadata = Metadata.default) c = + [%log.debug "Tree.add %a" pp_path k]; + update_tree ~cache:true t k + ~f:(fun _ -> Lwt.return_some (of_contents ~metadata c)) + ~f_might_return_empty_node:false + + let add_tree t k v = + [%log.debug "Tree.add_tree %a" pp_path k]; + update_tree ~cache:true t k + ~f:(fun _ -> Lwt.return_some v) + ~f_might_return_empty_node:true + + let remove t k = + [%log.debug "Tree.remove %a" pp_path k]; + update_tree ~cache:true t k + ~f:(fun _ -> Lwt.return_none) + ~f_might_return_empty_node:false + + let update_tree t k f = + [%log.debug "Tree.update_tree %a" pp_path k]; + update_tree ~cache:true t k ~f:(Lwt.wrap1 f) ~f_might_return_empty_node:true + + let import repo = function + | `Contents (k, m) -> ( + cnt.contents_mem <- cnt.contents_mem + 1; + P.Contents.mem (P.Repo.contents_t repo) k >|= function + | true -> + let env = Env.empty () in + Some (`Contents (Contents.of_key ~env repo k, m)) + | false -> None) + | `Node k -> ( + cnt.node_mem <- cnt.node_mem + 1; + P.Node.mem (P.Repo.node_t repo) k >|= function + | true -> + let env = Env.empty () in + Some (`Node (Node.of_key ~env repo k)) + | false -> None) + + let import_with_env ~env repo = function + | `Node k -> `Node (Node.of_key ~env repo k) + | `Contents (k, m) -> `Contents (Contents.of_key ~env repo k, m) + + let import_no_check repo f = + let env = Env.empty () in + import_with_env ~env repo f + + (* Given an arbitrary tree value, persist its contents to the given contents + and node stores via a depth-first {i post-order} traversal. We must export + a node's children before the node itself in order to get the {i keys} of + any un-persisted child values. *) + let export ?clear repo contents_t node_t n = + let cache = + match clear with + | Some true | None -> + (* This choice of [cache] flag has no impact, since we either + immediately clear the corresponding cache or are certain that + the it is already filled. *) + false + | Some false -> true + in + + let add_node n v k = + cnt.node_add <- cnt.node_add + 1; + let* key = P.Node.add node_t v in + let () = + (* Sanity check: Did we just store the same hash as the one represented + by the Tree.Node [n]? *) + match Node.cached_hash n with + | None -> + (* No hash is in [n]. Computing it would result in getting it from + [v] or rebuilding a private node. *) + () + | Some h' -> + let h = P.Node.Key.to_hash key in + if not (equal_hash h h') then + backend_invariant_violation + "@[Tree.export: added inconsistent node binding@,\ + key: %a@,\ + value: %a@,\ + computed hash: %a@]" pp_node_key key Node.pp_value v pp_hash h' + in + k key + in + + let add_node_map n (x : Node.map) k = + let node = + (* Since we traverse in post-order, all children of [x] have already + been added. Thus, their keys are cached and we can retrieve them. *) + cnt.node_val_v <- cnt.node_val_v + 1; + StepMap.to_seq x + |> Seq.map (fun (step, v) -> + match v with + | `Node n -> ( + match Node.cached_key n with + | Some k -> (step, `Node k) + | None -> + assertion_failure + "Encountered child node value with uncached key \ + during export:@,\ + @ @[%a@]" dump v) + | `Contents (c, m) -> ( + match Contents.cached_key c with + | Some k -> (step, `Contents (k, m)) + | None -> + assertion_failure + "Encountered child contents value with uncached key \ + during export:@,\ + @ @[%a@]" dump v)) + |> P.Node.Val.of_seq + in + add_node n node k + in + + let add_updated_node n (v : Node.value) (updates : Node.updatemap) k = + let node = + StepMap.fold + (fun k v acc -> + match v with + | Node.Remove -> P.Node.Val.remove acc k + | Node.Add (`Node n as v) -> ( + match Node.cached_key n with + | Some ptr -> P.Node.Val.add acc k (`Node ptr) + | None -> + assertion_failure + "Encountered child node value with uncached key during \ + export:@,\ + @ @[%a@]" dump v) + | Add (`Contents (c, m) as v) -> ( + match Contents.cached_key c with + | Some ptr -> P.Node.Val.add acc k (`Contents (ptr, m)) + | None -> + assertion_failure + "Encountered child contents value with uncached key \ + during export:@,\ + @ @[%a@]" dump v)) + updates v + in + add_node n node k + in + + let rec on_node : type r. [ `Node of node ] -> (node_key, r) cont_lwt = + fun (`Node n) k -> + let k key = + (* All the nodes in the exported tree should be cleaned using + [Node.export]. This ensures that [key] is stored in [n]. *) + Node.export ?clear repo n key; + k key + in + let has_repo = + match n.Node.v with + | Node.Key (repo', _) -> + if repo == repo' then true + else + (* Case 1. [n] is a key from another repo. Let's crash. + + We could also only crash if the hash in the key is unknown to + [repo], or completely ignore the issue. *) + failwith "Can't export the node key from another repo" + | Value (repo', _, _) -> + if repo == repo' then true + else + (* Case 2. [n] is a value from another repo. Let's crash. + + We could also ignore the issue. *) + failwith "Can't export a node value from another repo" + | Pruned _ | Portable_dirty _ | Map _ -> false + in + match n.Node.v with + | Pruned h -> + (* Case 3. [n] is a pruned hash. [P.Node.index node_t h] could be + different than [None], but let's always crash. *) + pruned_hash_exn "export" h + | Portable_dirty _ -> + (* Case 4. [n] is a portable value with diffs. The hash of the + reconstructed portable value could be known by [repo], but let's + always crash. *) + portable_value_exn "export" + | Map _ | Value _ | Key _ -> ( + match Node.cached_key n with + | Some key -> + if has_repo then + (* Case 5. [n] is a key that is accompanied by the [repo]. Let's + assume that [P.Node.mem node_t key] is [true] for performance + reason (not benched). *) + k key + else ( + cnt.node_mem <- cnt.node_mem + 1; + let* mem = P.Node.mem node_t key in + if not mem then + (* Case 6. [n] contains a key that is not known by [repo]. + Let's abort. *) + failwith "Can't export a key unkown from the repo" + else + (* Case 7. [n] contains a key that is known by the [repo]. *) + k key) + | None -> ( + let* skip_when_some = + match Node.cached_hash n with + | None -> + (* No pre-computed hash. *) + Lwt.return_none + | Some h -> ( + cnt.node_index <- cnt.node_index + 1; + P.Node.index node_t h >>= function + | None -> + (* Pre-computed hash is unknown by repo. + + NOTE: it's possible that this value already has a key + in the store, but it's not indexed. If so, we're + adding a duplicate here – this isn't an issue for + correctness, but does waste space. *) + Lwt.return_none + | Some key -> + cnt.node_mem <- cnt.node_mem + 1; + let+ mem = P.Node.mem node_t key in + if mem then + (* Case 8. The pre-computed hash is converted into + a key *) + Some key + else + (* The backend could produce a key from [h] but + doesn't know [h]. *) + None) + in + match skip_when_some with + | Some key -> k key + | None -> ( + (* Only [Map _ | Value _] possible now. + + Case 9. Let's export it to the backend. *) + let new_children_seq = + let seq = + match n.Node.v with + | Value (_, _, Some m) -> + StepMap.to_seq m + |> Seq.filter_map (function + | step, Node.Add v -> Some (step, v) + | _, Remove -> None) + | Map m -> StepMap.to_seq m + | Value (_, _, None) -> Seq.empty + | Key _ | Portable_dirty _ | Pruned _ -> + (* [n.v = (Key _ | Portable_dirty _ | Pruned _)] is + excluded above. *) + assert false + in + Seq.map (fun (_, x) -> x) seq + in + on_node_seq new_children_seq @@ fun `Node_children_exported -> + match (n.Node.v, Node.cached_value n) with + | Map x, _ -> add_node_map n x k + | Value (_, v, None), None | _, Some v -> add_node n v k + | Value (_, v, Some um), _ -> add_updated_node n v um k + | (Key _ | Portable_dirty _ | Pruned _), _ -> + (* [n.v = (Key _ | Portable_dirty _ | Pruned _)] is + excluded above. *) + assert false))) + and on_contents : + type r. + [ `Contents of Contents.t * metadata ] -> + ([ `Content_exported ], r) cont_lwt = + fun (`Contents (c, _)) k -> + match c.Contents.v with + | Contents.Key (_, key) -> + Contents.export ?clear repo c key; + k `Content_exported + | Contents.Value _ -> + let* v = Contents.to_value ~cache c in + let v = get_ok "export" v in + cnt.contents_add <- cnt.contents_add + 1; + let* key = P.Contents.add contents_t v in + let () = + let h = P.Contents.Key.to_hash key in + let h' = Contents.hash ~cache c in + if not (equal_hash h h') then + backend_invariant_violation + "@[Tree.export: added inconsistent contents binding@,\ + key: %a@,\ + value: %a@,\ + computed hash: %a@]" pp_contents_key key pp_contents v pp_hash + h' + in + Contents.export ?clear repo c key; + k `Content_exported + | Contents.Pruned h -> pruned_hash_exn "export" h + and on_node_seq : + type r. Node.elt Seq.t -> ([ `Node_children_exported ], r) cont_lwt = + fun seq k -> + match seq () with + | Seq.Nil -> + (* Have iterated on all children, let's export parent now *) + k `Node_children_exported + | Seq.Cons ((`Node _ as n), rest) -> + on_node n (fun _node_key -> on_node_seq rest k) + | Seq.Cons ((`Contents _ as c), rest) -> + on_contents c (fun `Content_exported -> on_node_seq rest k) + in + on_node (`Node n) (fun key -> Lwt.return key) + + let merge : t Merge.t = + let f ~old (x : t) y = + Merge.(f Node.merge_elt) ~old x y >>= function + | Ok t -> Merge.ok t + | Error e -> Lwt.return (Error e) + in + Merge.v t f + + let entries path tree = + let rec aux acc = function + | [] -> Lwt.return acc + | (path, h) :: todo -> + let* childs = Node.bindings ~cache:true h >|= get_ok "entries" in + let acc, todo = + List.fold_left + (fun (acc, todo) (k, v) -> + let path = Path.rcons path k in + match v with + | `Node v -> (acc, (path, v) :: todo) + | `Contents c -> ((path, c) :: acc, todo)) + (acc, todo) childs + in + (aux [@tailcall]) acc todo + in + (aux [@tailcall]) [] [ (path, tree) ] + + (** Given two forced lazy values, return an empty diff if they both use the + same dangling hash. *) + let diff_force_result (type a b) ~(empty : b) ~(diff_ok : a * a -> b) + (x : a or_error) (y : a or_error) : b = + match (x, y) with + | ( Error (`Dangling_hash h1 | `Pruned_hash h1), + Error (`Dangling_hash h2 | `Pruned_hash h2) ) -> ( + match equal_hash h1 h2 with true -> empty | false -> assert false) + | Error _, Ok _ -> assert false + | Ok _, Error _ -> assert false + | Ok x, Ok y -> diff_ok (x, y) + | Error _, Error _ -> assert false + + let diff_contents x y = + if Node.contents_equal x y then Lwt.return_nil + else + let* cx = Contents.to_value ~cache:true (fst x) in + let+ cy = Contents.to_value ~cache:true (fst y) in + diff_force_result cx cy ~empty:[] ~diff_ok:(fun (cx, cy) -> + [ `Updated ((cx, snd x), (cy, snd y)) ]) + + let diff_node (x : node) (y : node) = + let bindings n = + Node.to_map ~cache:true n >|= function + | Ok m -> Ok (StepMap.bindings m) + | Error _ as e -> e + in + let removed acc (k, (c, m)) = + let+ c = Contents.to_value ~cache:true c >|= get_ok "diff_node" in + (k, `Removed (c, m)) :: acc + in + let added acc (k, (c, m)) = + let+ c = Contents.to_value ~cache:true c >|= get_ok "diff_node" in + (k, `Added (c, m)) :: acc + in + let rec diff_bindings acc todo path x y = + let acc = ref acc in + let todo = ref todo in + let* () = + alist_iter2_lwt compare_step + (fun key v -> + let path = Path.rcons path key in + match v with + (* Left *) + | `Left (`Contents x) -> + let+ x = removed !acc (path, x) in + acc := x + | `Left (`Node x) -> + let* xs = entries path x in + let+ xs = Lwt_list.fold_left_s removed !acc xs in + acc := xs + (* Right *) + | `Right (`Contents y) -> + let+ y = added !acc (path, y) in + acc := y + | `Right (`Node y) -> + let* ys = entries path y in + let+ ys = Lwt_list.fold_left_s added !acc ys in + acc := ys + (* Both *) + | `Both (`Node x, `Node y) -> + todo := (path, x, y) :: !todo; + Lwt.return_unit + | `Both (`Contents x, `Node y) -> + let* ys = entries path y in + let* x = removed !acc (path, x) in + let+ ys = Lwt_list.fold_left_s added x ys in + acc := ys + | `Both (`Node x, `Contents y) -> + let* xs = entries path x in + let* y = added !acc (path, y) in + let+ ys = Lwt_list.fold_left_s removed y xs in + acc := ys + | `Both (`Contents x, `Contents y) -> + let+ content_diffs = + diff_contents x y >|= List.map (fun d -> (path, d)) + in + acc := content_diffs @ !acc) + x y + in + (diff_node [@tailcall]) !acc !todo + and diff_node acc = function + | [] -> Lwt.return acc + | (path, x, y) :: todo -> + if Node.equal x y then (diff_node [@tailcall]) acc todo + else + let* x = bindings x in + let* y = bindings y in + diff_force_result ~empty:Lwt.return_nil + ~diff_ok:(fun (x, y) -> diff_bindings acc todo path x y) + x y + in + (diff_node [@tailcall]) [] [ (Path.empty, x, y) ] + + let diff (x : t) (y : t) = + match (x, y) with + | `Contents ((c1, m1) as x), `Contents ((c2, m2) as y) -> + if contents_equal x y then Lwt.return_nil + else + let* c1 = Contents.to_value ~cache:true c1 >|= get_ok "diff" in + let* c2 = Contents.to_value ~cache:true c2 >|= get_ok "diff" in + Lwt.return [ (Path.empty, `Updated ((c1, m1), (c2, m2))) ] + | `Node x, `Node y -> diff_node x y + | `Contents (x, m), `Node y -> + let* diff = diff_node (Node.empty ()) y in + let+ x = Contents.to_value ~cache:true x >|= get_ok "diff" in + (Path.empty, `Removed (x, m)) :: diff + | `Node x, `Contents (y, m) -> + let* diff = diff_node x (Node.empty ()) in + let+ y = Contents.to_value ~cache:true y >|= get_ok "diff" in + (Path.empty, `Added (y, m)) :: diff + + type concrete = + [ `Tree of (Path.step * concrete) list + | `Contents of P.Contents.Val.t * Metadata.t ] + [@@deriving irmin] + + type 'a or_empty = Empty | Non_empty of 'a + + let of_concrete c = + let rec concrete : type r. concrete -> (t or_empty, r) cont = + fun t k -> + match t with + | `Contents (c, m) -> k (Non_empty (of_contents ~metadata:m c)) + | `Tree childs -> + tree StepMap.empty childs (function + | Empty -> k Empty + | Non_empty n -> k (Non_empty (`Node n))) + and tree : + type r. + Node.elt StepMap.t -> (step * concrete) list -> (node or_empty, r) cont + = + fun map t k -> + match t with + | [] -> + k + (if StepMap.is_empty map then Empty + else Non_empty (Node.of_map ~env:(Env.empty ()) map)) + | (s, n) :: t -> + (concrete [@tailcall]) n (fun v -> + (tree [@tailcall]) + (StepMap.update s + (function + | None -> ( + match v with + | Empty -> None (* Discard empty sub-directories *) + | Non_empty v -> Some v) + | Some _ -> + Fmt.invalid_arg + "of_concrete: duplicate bindings for step `%a`" + pp_step s) + map) + t k) + in + (concrete [@tailcall]) c (function Empty -> empty () | Non_empty x -> x) + + let to_concrete t = + let rec tree : type r. t -> (concrete, r) cont_lwt = + fun t k -> + match t with + | `Contents c -> contents c k + | `Node n -> + let* m = Node.to_map ~cache:true n in + let bindings = m |> get_ok "to_concrete" |> StepMap.bindings in + (node [@tailcall]) [] bindings (fun n -> + let n = List.sort (fun (s, _) (s', _) -> compare_step s s') n in + k (`Tree n)) + and contents : type r. Contents.t * metadata -> (concrete, r) cont_lwt = + fun (c, m) k -> + let* c = Contents.to_value ~cache:true c >|= get_ok "to_concrete" in + k (`Contents (c, m)) + and node : + type r. + (step * concrete) list -> + (step * Node.elt) list -> + ((step * concrete) list, r) cont_lwt = + fun childs x k -> + match x with + | [] -> k childs + | (s, n) :: t -> ( + match n with + | `Node _ as n -> + (tree [@tailcall]) n (fun tree -> node ((s, tree) :: childs) t k) + | `Contents c -> + (contents [@tailcall]) c (fun c -> + (node [@tailcall]) ((s, c) :: childs) t k)) + in + tree t (fun x -> Lwt.return x) + + let key (t : t) = + [%log.debug "Tree.key"]; + match t with + | `Node n -> ( + match Node.key n with Some key -> Some (`Node key) | None -> None) + | `Contents (c, m) -> ( + match Contents.key c with + | Some key -> Some (`Contents (key, m)) + | None -> None) + + let hash ?(cache = true) (t : t) = + [%log.debug "Tree.hash"]; + match t with + | `Node n -> `Node (Node.hash ~cache n) + | `Contents (c, m) -> `Contents (Contents.hash ~cache c, m) + + let stats ?(force = false) (t : t) = + let cache = true in + let force = + if force then `True + else `False (fun k s -> set_depth k s |> incr_skips |> Lwt.return) + in + let contents k _ s = set_depth k s |> incr_leafs |> Lwt.return in + let pre k childs s = + if childs = [] then Lwt.return s + else set_depth k s |> set_width childs |> incr_nodes |> Lwt.return + in + let post _ _ acc = Lwt.return acc in + fold ~force ~cache ~pre ~post ~contents t empty_stats + + let counters () = cnt + let dump_counters ppf () = dump_counters ppf cnt + let reset_counters () = reset_counters cnt + + let inspect = function + | `Contents _ -> `Contents + | `Node n -> + `Node + (match n.Node.v with + | Map _ -> `Map + | Value _ -> `Value + | Key _ -> `Key + | Portable_dirty _ -> `Portable_dirty + | Pruned _ -> `Pruned) + + module Proof = struct + type irmin_tree = t + + include Tree_proof + + type proof_tree = tree + type proof_inode = inode_tree + type node_proof = P.Node_portable.proof + + let proof_of_iproof : proof_inode -> proof_tree = function + | Blinded_inode h -> Blinded_node h + | Inode_values l -> Node l + | Inode_tree i -> Inode i + | Inode_extender ext -> Extender ext + + let rec proof_of_tree : type a. irmin_tree -> (proof_tree -> a) -> a = + fun tree k -> + match tree with + | `Contents (c, h) -> proof_of_contents c h k + | `Node node -> proof_of_node node k + + and proof_of_contents : + type a. Contents.t -> metadata -> (proof_tree -> a) -> a = + fun c m k -> + match Contents.cached_value c with + | Some v -> k (Contents (v, m)) + | None -> k (Blinded_contents (Contents.hash c, m)) + + and proof_of_node : type a. node -> (proof_tree -> a) -> a = + fun node k -> + (* Let's convert [node] to [node_proof]. + + As [node] might not be exported, we can only turn it into a portable + node. *) + let to_portable_value = + let value_of_key ~cache:_ _node _repo k = + let h = P.Node.Key.to_hash k in + err_dangling_hash h + in + Node.to_portable_value_aux ~cache:false ~value_of_key ~return:Fun.id + ~bind:(fun x f -> f x) + in + match to_portable_value node with + | Error (`Dangling_hash h) -> k (Blinded_node h) + | Error (`Pruned_hash h) -> k (Blinded_node h) + | Ok v -> + (* [to_proof] may trigger reads. This is fine. *) + let node_proof = P.Node_portable.to_proof v in + proof_of_node_proof node node_proof k + + (** [of_node_proof n np] is [p] (of type [Tree.Proof.t]) which is very + similar to [np] (of type [P.Node.Val.proof]) except that the values + loaded in [n] have been expanded. *) + and proof_of_node_proof : + type a. node -> node_proof -> (proof_tree -> a) -> a = + fun node p k -> + match p with + | `Blinded h -> k (Blinded_node h) + | `Inode (length, proofs) -> + iproof_of_inode node length proofs (fun p -> proof_of_iproof p |> k) + | `Values vs -> iproof_of_values node vs (fun p -> proof_of_iproof p |> k) + + and iproof_of_node_proof : + type a. node -> node_proof -> (proof_inode -> a) -> a = + fun node p k -> + match p with + | `Blinded h -> k (Blinded_inode h) + | `Inode (length, proofs) -> iproof_of_inode node length proofs k + | `Values vs -> iproof_of_values node vs k + + and iproof_of_inode : + type a. node -> int -> (_ * node_proof) list -> (proof_inode -> a) -> a + = + fun node length proofs k -> + let rec aux acc = function + | [] -> k (Inode_tree { length; proofs = List.rev acc }) + | (index, proof) :: rest -> + iproof_of_node_proof node proof (fun proof -> + aux ((index, proof) :: acc) rest) + in + (* We are dealing with an inode A. + Its children are Bs. + The children of Bs are Cs. + *) + match proofs with + | [ (index, proof) ] -> + (* A has 1 child. *) + iproof_of_node_proof node proof (function + | Inode_tree { length = length'; proofs = [ (i, p) ] } -> + (* B is an inode with 1 child, C isn't. *) + assert (length = length'); + k + (Inode_extender { length; segments = [ index; i ]; proof = p }) + | Inode_extender { length = length'; segments; proof } -> + (* B is an inode with 1 child, so is C. *) + assert (length = length'); + k + (Inode_extender + { length; segments = index :: segments; proof }) + | (Blinded_inode _ | Inode_values _ | Inode_tree _) as p -> + (* B is not an inode with 1 child. *) + k (Inode_tree { length; proofs = [ (index, p) ] })) + | _ -> aux [] proofs + + and iproof_of_values : + type a. + node -> (step * Node.pnode_value) list -> (proof_inode -> a) -> a = + let findv = + let value_of_key ~cache:_ _node _repo k = + let h = P.Node.Key.to_hash k in + err_dangling_hash h + in + Node.findv_aux ~value_of_key ~return:Fun.id ~bind:(fun x f -> f x) + in + fun node steps k -> + let rec aux acc = function + | [] -> k (Inode_values (List.rev acc)) + | (step, _) :: rest -> ( + match findv ~cache:false "Proof.iproof_of_values" node step with + | None -> assert false + | Some t -> + let k p = aux ((step, p) :: acc) rest in + proof_of_tree t k) + in + aux [] steps + + let of_tree t = proof_of_tree t Fun.id + + let rec load_proof : type a. env:_ -> proof_tree -> (kinded_hash -> a) -> a + = + fun ~env p k -> + match p with + | Blinded_node h -> k (`Node h) + | Node n -> load_node_proof ~env n k + | Inode { length; proofs } -> load_inode_proof ~env length proofs k + | Blinded_contents (h, m) -> k (`Contents (h, m)) + | Contents (v, m) -> + let h = P.Contents.Hash.hash v in + Env.add_contents_from_proof env h v; + k (`Contents (h, m)) + | Extender { length; segments; proof } -> + load_extender_proof ~env length segments proof k + + (* Recontruct private node from [P.Node.Val.proof] *) + and load_extender_proof : + type a. + env:_ -> int -> int list -> proof_inode -> (kinded_hash -> a) -> a = + fun ~env len segments p k -> + node_proof_of_proof ~env p (fun p -> + let np = proof_of_extender len segments p in + let v = P.Node_portable.of_proof ~depth:0 np in + let v = + match v with + | None -> Proof.bad_proof_exn "Invalid proof" + | Some v -> v + in + let h = P.Node_portable.hash_exn v in + Env.add_pnode_from_proof env h v; + k (`Node h)) + + and proof_of_extender len segments p : node_proof = + List.fold_left + (fun acc index -> `Inode (len, [ (index, acc) ])) + p (List.rev segments) + + (* Recontruct private node from [P.Node.Val.empty] *) + and load_node_proof : + type a. env:_ -> (step * proof_tree) list -> (kinded_hash -> a) -> a = + fun ~env n k -> + let rec aux acc = function + | [] -> + let h = P.Node_portable.hash_exn acc in + Env.add_pnode_from_proof env h acc; + k (`Node h) + | (s, p) :: rest -> + let k h = aux (P.Node_portable.add acc s h) rest in + load_proof ~env p k + in + aux (P.Node_portable.empty ()) n + + (* Recontruct private node from [P.Node.Val.proof] *) + and load_inode_proof : + type a. + env:_ -> int -> (_ * proof_inode) list -> (kinded_hash -> a) -> a = + fun ~env len proofs k -> + let rec aux : _ list -> _ list -> a = + fun acc proofs -> + match proofs with + | [] -> + let np = `Inode (len, List.rev acc) in + let v = P.Node_portable.of_proof ~depth:0 np in + let v = + match v with + | None -> Proof.bad_proof_exn "Invalid proof" + | Some v -> v + in + let h = P.Node_portable.hash_exn v in + Env.add_pnode_from_proof env h v; + k (`Node h) + | (i, p) :: rest -> + let k p = aux ((i, p) :: acc) rest in + node_proof_of_proof ~env p k + in + aux [] proofs + + and node_proof_of_proof : + type a. env:_ -> proof_inode -> (node_proof -> a) -> a = + fun ~env t k -> + match t with + | Blinded_inode x -> k (`Blinded x) + | Inode_tree { length; proofs } -> + node_proof_of_inode ~env length proofs k + | Inode_values n -> node_proof_of_node ~env n k + | Inode_extender { length; segments; proof } -> + node_proof_of_proof ~env proof (fun p -> + k (proof_of_extender length segments p)) + + and node_proof_of_inode : + type a. env:_ -> int -> (_ * proof_inode) list -> (node_proof -> a) -> a + = + fun ~env length proofs k -> + let rec aux acc = function + | [] -> k (`Inode (length, List.rev acc)) + | (i, p) :: rest -> + node_proof_of_proof ~env p (fun p -> aux ((i, p) :: acc) rest) + in + aux [] proofs + + and node_proof_of_node : + type a. env:_ -> (step * proof_tree) list -> (node_proof -> a) -> a = + fun ~env node k -> + let rec aux acc = function + | [] -> k (`Values (List.rev acc)) + | (s, p) :: rest -> + load_proof ~env p (fun n -> aux ((s, n) :: acc) rest) + in + aux [] node + + let to_tree p = + let env = Env.empty () in + Env.set_mode env Env.Set Env.Deserialise; + let h = load_proof ~env (state p) Fun.id in + let tree = pruned_with_env ~env h in + Env.set_mode env Env.Set Env.Consume; + tree + end + + let produce_proof repo kinded_key f = + Env.with_set_produce @@ fun env ~start_serialise -> + let tree = import_with_env ~env repo kinded_key in + let+ tree_after, result = f tree in + let after = hash tree_after in + (* Here, we build a proof from [tree] (not from [tree_after]!), on purpose: + we look at the effect on [f] on [tree]'s caches and we rely on the fact + that the caches are env across copy-on-write copies of [tree]. *) + clear tree; + start_serialise (); + let proof = Proof.of_tree tree in + (* [env] will be purged when leaving the scope, that should avoid any memory + leaks *) + let kinded_hash = Node.weaken_value kinded_key in + (Proof.v ~before:kinded_hash ~after proof, result) + + let produce_stream repo kinded_key f = + Env.with_stream_produce @@ fun env ~to_stream -> + let tree = import_with_env ~env repo kinded_key in + let+ tree_after, result = f tree in + let after = hash tree_after in + clear tree; + let proof = to_stream () in + let kinded_hash = Node.weaken_value kinded_key in + (Proof.v ~before:kinded_hash ~after proof, result) + + let verify_proof_exn p f = + Env.with_set_consume @@ fun env ~stop_deserialise -> + let before = Proof.before p in + let after = Proof.after p in + (* First convert to proof to [Env] *) + let h = Proof.(load_proof ~env (state p) Fun.id) in + (* Then check that the consistency of the proof *) + if not (equal_kinded_hash before h) then + Irmin_proof.bad_proof_exn "verify_proof: invalid before hash"; + let tree = pruned_with_env ~env h in + Lwt.catch + (fun () -> + stop_deserialise (); + (* Then apply [f] on a cleaned tree, an exception will be raised if [f] + reads out of the proof. *) + let+ tree_after, result = f tree in + (* then check that [after] corresponds to [tree_after]'s hash. *) + if not (equal_kinded_hash after (hash tree_after)) then + Irmin_proof.bad_proof_exn "verify_proof: invalid after hash"; + (tree_after, result)) + (function + | Pruned_hash h -> + (* finaly check that [f] only access valid parts of the proof. *) + Fmt.kstr Irmin_proof.bad_proof_exn + "verify_proof: %s is trying to read through a blinded node or \ + object (%a)" + h.context pp_hash h.hash + | e -> raise e) + + type verifier_error = + [ `Proof_mismatch of string + | `Stream_too_long of string + | `Stream_too_short of string ] + [@@deriving irmin] + + let verify_proof p f = + Lwt.catch + (fun () -> + let+ r = verify_proof_exn p f in + Ok r) + (function + | Irmin_proof.Bad_proof e -> + Lwt.return (Error (`Proof_mismatch e.context)) + | e -> Lwt.fail e) + + let verify_stream_exn p f = + let before = Proof.before p in + let after = Proof.after p in + let stream = Proof.state p in + Env.with_stream_consume stream @@ fun env ~is_empty -> + let tree = pruned_with_env ~env before in + Lwt.catch + (fun () -> + let+ tree_after, result = f tree in + if not (is_empty ()) then + Irmin_proof.bad_stream_too_long "verify_stream" + "did not consume the full stream"; + if not (equal_kinded_hash after (hash tree_after)) then + Irmin_proof.bad_stream_exn "verify_stream" "invalid after hash"; + (tree_after, result)) + (function + | Pruned_hash h -> + Fmt.kstr + (Irmin_proof.bad_stream_exn "verify_stream") + "%s is trying to read through a blinded node or object (%a)" + h.context pp_hash h.hash + | e -> raise e) + + let verify_stream p f = + Lwt.catch + (fun () -> + let+ r = verify_stream_exn p f in + Ok r) + (function + | Irmin_proof.Bad_stream (Stream_too_long e) -> + Fmt.kstr + (fun e -> Lwt.return (Error (`Stream_too_long e))) + "Bad_stream %s: %s" e.context e.reason + | Irmin_proof.Bad_stream (Stream_too_short e) -> + Fmt.kstr + (fun e -> Lwt.return (Error (`Stream_too_short e))) + "Bad_stream %s: %s" e.context e.reason + | Irmin_proof.Bad_stream (Proof_mismatch e) -> + Fmt.kstr + (fun e -> Lwt.return (Error (`Proof_mismatch e))) + "Bad_stream %s: %s" e.context e.reason + | e -> Lwt.fail e) + + module Private = struct + let get_env = get_env + + module Env = Env + end +end diff --git a/vendors/irmin/src/irmin/tree.mli b/vendors/irmin/src/irmin/tree.mli new file mode 100644 index 0000000000000000000000000000000000000000..53cb60905ca4087f9ee873705587cdfc5e71983e --- /dev/null +++ b/vendors/irmin/src/irmin/tree.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Tree_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/tree_intf.ml b/vendors/irmin/src/irmin/tree_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..a59af73f3b076a1fd74973d7d3fe223235bcafe6 --- /dev/null +++ b/vendors/irmin/src/irmin/tree_intf.ml @@ -0,0 +1,503 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + type path [@@deriving irmin] + type step [@@deriving irmin] + type metadata [@@deriving irmin] + type contents [@@deriving irmin] + type contents_key [@@deriving irmin] + type node [@@deriving irmin] + type hash [@@deriving irmin] + + (** [Tree] provides immutable, in-memory partial mirror of the store, with + lazy reads and delayed writes. + + Trees are like staging area in Git: they are immutable temporary + non-persistent areas (they disappear if the host crash), held in memory + for efficiency, where reads are done lazily and writes are done only when + needed on commit: if you modify a key twice, only the last change will be + written to the store when you commit. *) + + type t [@@deriving irmin] + (** The type of trees. *) + + (** {1 Constructors} *) + + val empty : unit -> t + (** [empty ()] is the empty tree. The empty tree does not have associated + backend configuration values, as they can perform in-memory operation, + independently of any given backend. *) + + val singleton : path -> ?metadata:metadata -> contents -> t + (** [singleton k c] is the tree with a single binding mapping the key [k] to + the contents [c]. *) + + val of_contents : ?metadata:metadata -> contents -> t + (** [of_contents c] is the subtree built from the contents [c]. *) + + val of_node : node -> t + (** [of_node n] is the subtree built from the node [n]. *) + + type elt = [ `Node of node | `Contents of contents * metadata ] + (** The type for tree elements. *) + + val v : elt -> t + (** General-purpose constructor for trees. *) + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + + val pruned : kinded_hash -> t + (** [pruned h] is a purely in-memory tree with the hash [h]. Such trees can be + used as children of other in-memory tree nodes, for instance in order to + compute the hash of the parent, but they cannot be dereferenced. + + Any operation that would require loading the contents of a pruned node + (e.g. calling {!find} on one of its children) will instead raise a + {!Pruned_hash} exception. Attempting to export a tree containing pruned + sub-trees to a repository will fail similarly. *) + + val kind : t -> path -> [ `Contents | `Node ] option Lwt.t + (** [kind t k] is the type of [s] in [t]. It could either be a tree node or + some file contents. It is [None] if [k] is not present in [t]. *) + + val is_empty : t -> bool + (** [is_empty t] is true iff [t] is {!empty} (i.e. a tree node with no + children). Trees with {!kind} = [`Contents] are never considered empty. *) + + (** {1 Diffs} *) + + val diff : t -> t -> (path * (contents * metadata) Diff.t) list Lwt.t + (** [diff x y] is the difference of contents between [x] and [y]. *) + + (** {1 Manipulating Contents} *) + + exception Dangling_hash of { context : string; hash : hash } + (** The exception raised by functions that can force lazy tree nodes but do + not return an explicit {!or_error}. *) + + exception Pruned_hash of { context : string; hash : hash } + (** The exception raised by functions that attempts to load {!pruned} tree + nodes. *) + + exception Portable_value of { context : string } + (** The exception raised by functions that attemps to perform IO on a portable + tree. *) + + type error = + [ `Dangling_hash of hash | `Pruned_hash of hash | `Portable_value ] + + type 'a or_error = ('a, error) result + + (** Operations on lazy tree contents. *) + module Contents : sig + type t + (** The type of lazy tree contents. *) + + val hash : ?cache:bool -> t -> hash + (** [hash t] is the hash of the {!contents} value returned when [t] is + {!val-force}d successfully. See {!caching} for an explanation of the + [cache] parameter. *) + + val key : t -> contents_key option + (** [key t] is the key of the {!contents} value returned when [t] is + {!val-force}d successfully. *) + + val force : t -> contents or_error Lwt.t + (** [force t] forces evaluation of the lazy content value [t], or returns an + error if no such value exists in the underlying repository. *) + + val force_exn : t -> contents Lwt.t + (** Equivalent to {!val-force}, but raises an exception if the lazy content + value is not present in the underlying repository. *) + + val clear : t -> unit + (** [clear t] clears [t]'s cache. *) + + (** {2:caching caching} + + [cache] regulates the caching behaviour regarding the node's internal + data which are be lazily loaded from the backend. + + [cache] defaults to [true] which may greatly reduce the IOs and the + runtime but may also grealy increase the memory consumption. + + [cache = false] doesn't replace a call to [clear], it only prevents the + storing of new data, it doesn't discard the existing one. *) + end + + val mem : t -> path -> bool Lwt.t + (** [mem t k] is true iff [k] is associated to some contents in [t]. *) + + val find_all : t -> path -> (contents * metadata) option Lwt.t + (** [find_all t k] is [Some (b, m)] if [k] is associated to the contents [b] + and metadata [m] in [t] and [None] if [k] is not present in [t]. *) + + val length : t -> ?cache:bool -> path -> int Lwt.t + (** [length t key] is the number of files and sub-nodes stored under [key] in + [t]. + + It is equivalent to [List.length (list t k)] but backends might optimise + this call: for instance it's a constant time operation in [irmin-pack]. + + [cache] defaults to [true], see {!caching} for an explanation of the + parameter.*) + + val find : t -> path -> contents option Lwt.t + (** [find] is similar to {!find_all} but it discards metadata. *) + + val get_all : t -> path -> (contents * metadata) Lwt.t + (** Same as {!find_all} but raise [Invalid_arg] if [k] is not present in [t]. *) + + val list : + t -> + ?offset:int -> + ?length:int -> + ?cache:bool -> + path -> + (step * t) list Lwt.t + (** [list t key] is the list of files and sub-nodes stored under [k] in [t]. + The result order is not specified but is stable. + + [offset] and [length] are used for pagination. + + [cache] defaults to [true], see {!Contents.caching} for an explanation of + the parameter. *) + + val seq : + t -> + ?offset:int -> + ?length:int -> + ?cache:bool -> + path -> + (step * t) Seq.t Lwt.t + (** [seq t key] follows the same behavior as {!list} but returns a sequence. *) + + val get : t -> path -> contents Lwt.t + (** Same as {!get_all} but ignore the metadata. *) + + val add : t -> path -> ?metadata:metadata -> contents -> t Lwt.t + (** [add t k c] is the tree where the key [k] is bound to the contents [c] but + is similar to [t] for other bindings. *) + + val update : + t -> + path -> + ?metadata:metadata -> + (contents option -> contents option) -> + t Lwt.t + (** [update t k f] is the tree [t'] that is the same as [t] for all keys + except [k], and whose binding for [k] is determined by [f (find t k)]. + + If [k] refers to an internal node of [t], [f] is called with [None] to + determine the value with which to replace it. *) + + val remove : t -> path -> t Lwt.t + (** [remove t k] is the tree where [k] bindings has been removed but is + similar to [t] for other bindings. *) + + (** {1 Manipulating Subtrees} *) + + val mem_tree : t -> path -> bool Lwt.t + (** [mem_tree t k] is false iff [find_tree k = None]. *) + + val find_tree : t -> path -> t option Lwt.t + (** [find_tree t k] is [Some v] if [k] is associated to [v] in [t]. It is + [None] if [k] is not present in [t]. *) + + val get_tree : t -> path -> t Lwt.t + (** [get_tree t k] is [v] if [k] is associated to [v] in [t]. Raise + [Invalid_arg] if [k] is not present in [t].*) + + val add_tree : t -> path -> t -> t Lwt.t + (** [add_tree t k v] is the tree where the key [k] is bound to the non-empty + tree [v] but is similar to [t] for other bindings. + + If [v] is empty, this is equivalent to [remove t k]. *) + + val update_tree : t -> path -> (t option -> t option) -> t Lwt.t + (** [update_tree t k f] is the tree [t'] that is the same as [t] for all + subtrees except under [k], and whose subtree at [k] is determined by + [f (find_tree t k)]. + + [f] returning either [None] or [Some empty] causes the subtree at [k] to + be unbound (i.e. it is equivalent to [remove t k]). *) + + val merge : t Merge.t + (** [merge] is the 3-way merge function for trees. *) + + (** {1 Folds} *) + + val destruct : t -> [ `Node of node | `Contents of Contents.t * metadata ] + (** General-purpose destructor for trees. *) + + type marks + (** The type for fold marks. *) + + val empty_marks : unit -> marks + (** [empty_marks ()] is an empty collection of marks. *) + + type 'a force = [ `True | `False of path -> 'a -> 'a Lwt.t ] + (** The type for {!fold}'s [force] parameter. [`True] forces the fold to read + the objects of the lazy nodes and contents. [`False f] is applying [f] on + every lazy node and content value instead. *) + + type uniq = [ `False | `True | `Marks of marks ] + (** The type for {!fold}'s [uniq] parameters. [`False] folds over all the + nodes. [`True] does not recurse on nodes already seen. [`Marks m] uses the + collection of marks [m] to store the cache of keys: the fold will modify + [m]. This can be used for incremental folds. *) + + type ('a, 'b) folder = path -> 'b -> 'a -> 'a Lwt.t + (** The type for {!fold}'s folders: [pre], [post], [contents], [node], and + [tree], where ['a] is the accumulator and ['b] is the item folded. *) + + type depth = [ `Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int ] + [@@deriving irmin] + (** The type for fold depths. + + - [Eq d] folds over nodes and contents of depth exactly [d]. + - [Lt d] folds over nodes and contents of depth strictly less than [d]. + - [Gt d] folds over nodes and contents of depth strictly more than [d]. + + [Le d] is [Eq d] and [Lt d]. [Ge d] is [Eq d] and [Gt d]. *) + + val fold : + ?order:[ `Sorted | `Undefined | `Random of Random.State.t ] -> + ?force:'a force -> + ?cache:bool -> + ?uniq:uniq -> + ?pre:('a, step list) folder -> + ?post:('a, step list) folder -> + ?depth:depth -> + ?contents:('a, contents) folder -> + ?node:('a, node) folder -> + ?tree:('a, t) folder -> + t -> + 'a -> + 'a Lwt.t + (** [fold t acc] folds over [t]'s nodes with node-specific folders: + [contents], [node], and [tree], based on a node's {!kind}. + + The default for all folders is identity. + + For every node [n] of [t], including itself: + + - If [n] is a [`Contents] kind, call [contents path c] where [c] is the + {!contents} of [n]. + - If [n] is a [`Node] kind, (1) call [pre path steps]; (2) call + [node path n]; (3) recursively fold on each child; (4) call + [post path steps]. + - If [n] is any kind, call [tree path t'] where [t'] is the tree of [n]. + + See {{:https://github.com/mirage/irmin/blob/main/examples/fold.ml} + examples/fold.ml} for a demo of the different {!folder}s. + + See {!force} for details about the [force] parameters. By default it is + [`True]. + + See {!uniq} for details about the [uniq] parameters. By default it is + [`False]. + + The fold depth is controlled by the [depth] parameter. + + [cache] defaults to [false], see {!Contents.caching} for an explanation of + the parameter. + + If [order] is [`Sorted] (the default), the elements are traversed in + lexicographic order of their keys. If [`Random state], they are traversed + in a random order. For large nodes, these two modes are memory-consuming, + use [`Undefined] for a more memory efficient [fold]. *) + + (** {1 Stats} *) + + type stats = { + nodes : int; (** Number of node. *) + leafs : int; (** Number of leafs. *) + skips : int; (** Number of lazy nodes. *) + depth : int; (** Maximal depth. *) + width : int; (** Maximal width. *) + } + [@@deriving irmin] + (** The type for tree stats. *) + + val stats : ?force:bool -> t -> stats Lwt.t + (** [stats ~force t] are [t]'s statistics. If [force] is true, this will force + the reading of lazy nodes. By default it is [false]. *) + + (** {1 Concrete Trees} *) + + type concrete = + [ `Tree of (step * concrete) list | `Contents of contents * metadata ] + [@@deriving irmin] + (** The type for concrete trees. *) + + val of_concrete : concrete -> t + (** [of_concrete c] is the subtree equivalent of the concrete tree [c]. + + @raise Invalid_argument + if [c] contains duplicate bindings for a given path. *) + + val to_concrete : t -> concrete Lwt.t + (** [to_concrete t] is the concrete tree equivalent of the subtree [t]. *) + + (** {1 Proofs} *) + + module Proof : sig + include + Proof.S + with type contents := contents + and type hash := hash + and type step := step + and type metadata := metadata + + type irmin_tree + + val to_tree : tree t -> irmin_tree + (** [to_tree p] is the tree [t] representing the tree proof [p]. Blinded + parts of the proof will raise [Dangling_hash] when traversed. *) + end + with type irmin_tree := t + + (** {1 Caches} *) + + val clear : ?depth:int -> t -> unit + (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a + depth higher than [depth]. If [depth] is not set, all of the subtrees are + cleared. + + A call to [clear] doesn't discard the subtrees of [t], only their cache + are discarded. Even the lazily loaded and unmodified subtrees remain. *) + + (** {1 Performance counters} *) + + type counters = { + mutable contents_hash : int; + mutable contents_find : int; + mutable contents_add : int; + mutable contents_mem : int; + mutable node_hash : int; + mutable node_mem : int; + mutable node_index : int; + mutable node_add : int; + mutable node_find : int; + mutable node_val_v : int; + mutable node_val_find : int; + mutable node_val_list : int; + } + + val counters : unit -> counters + val dump_counters : unit Fmt.t + val reset_counters : unit -> unit + + val inspect : + t -> + [ `Contents | `Node of [ `Map | `Key | `Value | `Portable_dirty | `Pruned ] ] + (** [inspect t] is similar to {!kind}, with additional state information for + nodes. It is primarily useful for debugging and testing. + + If [t] holds a node, additional information about its state is included: + + - [`Map], if [t] is from {!of_concrete}. + - [`Value], if [t]'s node has modifications that have not been persisted + to a store. + - [`Portable_dirty], if [t]'s node has modifications and is + {!Node.Portable}. Currently only used with {!Proof}. + - [`Pruned], if [t] is from {!pruned}. + - Otherwise [`Key], the default state for a node loaded from a store. *) + + module Private : sig + module Env : sig + type t [@@deriving irmin] + + val is_empty : t -> bool + end + + val get_env : t -> Env.t + end +end + +module type Sigs = sig + module type S = sig + include S + (** @inline *) + end + + module Make (B : Backend.S) : sig + include + S + with type path = B.Node.Path.t + and type step = B.Node.Path.step + and type metadata = B.Node.Metadata.t + and type contents = B.Contents.value + and type contents_key = B.Contents.Key.t + and type hash = B.Hash.t + + type kinded_key = + [ `Contents of B.Contents.Key.t * metadata | `Node of B.Node.Key.t ] + [@@deriving irmin] + + val import : B.Repo.t -> kinded_key -> t option Lwt.t + val import_no_check : B.Repo.t -> kinded_key -> t + + val export : + ?clear:bool -> + B.Repo.t -> + [> write ] B.Contents.t -> + [> read_write ] B.Node.t -> + node -> + B.Node.key Lwt.t + + val dump : t Fmt.t + val equal : t -> t -> bool + val key : t -> kinded_key option + val hash : ?cache:bool -> t -> kinded_hash + val to_backend_node : node -> B.Node.Val.t Lwt.t + val to_backend_portable_node : node -> B.Node_portable.t Lwt.t + val of_backend_node : B.Repo.t -> B.Node.value -> node + + type ('proof, 'result) producer := + B.Repo.t -> + kinded_key -> + (t -> (t * 'result) Lwt.t) -> + ('proof * 'result) Lwt.t + + type verifier_error = + [ `Proof_mismatch of string + | `Stream_too_long of string + | `Stream_too_short of string ] + [@@deriving irmin] + + type ('proof, 'result) verifier := + 'proof -> + (t -> (t * 'result) Lwt.t) -> + (t * 'result, verifier_error) result Lwt.t + + type tree_proof := Proof.tree Proof.t + + val produce_proof : (tree_proof, 'a) producer + val verify_proof : (tree_proof, 'a) verifier + + type stream_proof := Proof.stream Proof.t + + val produce_stream : (stream_proof, 'a) producer + val verify_stream : (stream_proof, 'a) verifier + end +end diff --git a/vendors/irmin/src/irmin/type.ml b/vendors/irmin/src/irmin/type.ml new file mode 100644 index 0000000000000000000000000000000000000000..dbf9c23465441e975d7a49a1b3fe028249fbf5d5 --- /dev/null +++ b/vendors/irmin/src/irmin/type.ml @@ -0,0 +1,23 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Repr + +module type Defaultable = sig + include S + + val default : t +end diff --git a/vendors/irmin/src/irmin/type.mli b/vendors/irmin/src/irmin/type.mli new file mode 100644 index 0000000000000000000000000000000000000000..af092cd150436c8eb0cc9140454b2bd72be24e57 --- /dev/null +++ b/vendors/irmin/src/irmin/type.mli @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include module type of Repr +(** @inline *) + +module type Defaultable = sig + include S + + val default : t +end diff --git a/vendors/irmin/src/irmin/unix/dune b/vendors/irmin/src/irmin/unix/dune new file mode 100644 index 0000000000000000000000000000000000000000..91c2b8683f2b381cbd39a27862d257db10f36ca1 --- /dev/null +++ b/vendors/irmin/src/irmin/unix/dune @@ -0,0 +1,8 @@ +(library + (name irmin_unix) + (public_name irmin.unix) + (libraries irmin unix irmin-watcher) + (preprocess + (pps ppx_irmin.internal)) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/irmin/unix/info.ml b/vendors/irmin/src/irmin/unix/info.ml new file mode 100644 index 0000000000000000000000000000000000000000..fc9c616befaead0a35f57ea2bfcea5d0c1c53f82 --- /dev/null +++ b/vendors/irmin/src/irmin/unix/info.ml @@ -0,0 +1,33 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Irmin.Info.S) = struct + include I + + let v ?author fmt = + Fmt.kstr + (fun message () -> + let date = Int64.of_float (Unix.gettimeofday ()) in + let author = + match author with + | Some a -> a + | None -> + Printf.sprintf "Irmin %s.[%d]" (Unix.gethostname ()) + (Unix.getpid ()) + in + v ~author ~message date) + fmt +end diff --git a/vendors/irmin/src/irmin/unix/info.mli b/vendors/irmin/src/irmin/unix/info.mli new file mode 100644 index 0000000000000000000000000000000000000000..ac89da221d9ecc9d8246e956a05a1851421374a2 --- /dev/null +++ b/vendors/irmin/src/irmin/unix/info.mli @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Irmin.Info.S) : sig + include Irmin.Info.S with type t = I.t + + val v : ?author:string -> ('b, Format.formatter, unit, f) format4 -> 'b +end diff --git a/vendors/irmin/src/irmin/unix/irmin_unix.ml b/vendors/irmin/src/irmin/unix/irmin_unix.ml new file mode 100644 index 0000000000000000000000000000000000000000..3dab92c53c152e227c13741148090757cdae7aa4 --- /dev/null +++ b/vendors/irmin/src/irmin/unix/irmin_unix.ml @@ -0,0 +1,23 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Info = Info.Make +module I = Info (Irmin.Info.Default) + +let info = I.v + +let set_listen_dir_hook () = + Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook diff --git a/vendors/irmin/src/irmin/unix/irmin_unix.mli b/vendors/irmin/src/irmin/unix/irmin_unix.mli new file mode 100644 index 0000000000000000000000000000000000000000..95f2e686890b0433a173abf0ee57ace9714fd6b0 --- /dev/null +++ b/vendors/irmin/src/irmin/unix/irmin_unix.mli @@ -0,0 +1,34 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** {1 Irmin Unix utilities} + + This module provides utilities for Unix applications. *) + +module Info = Info.Make + +val info : + ?author:string -> + ('a, Format.formatter, unit, unit -> Irmin.Info.default) format4 -> + 'a +(** [info fmt ()] creates a fresh commit info, with the {{!Irmin.Info.S.date} + date} set to [Unix.gettimeoday ()] and the {{!Irmin.Info.S.author} author} + built using [Unix.gethostname()] and [Unix.getpid()] if [author] is not + provided. *) + +val set_listen_dir_hook : unit -> unit +(** Install {!Irmin_watcher.hook} as the listen hook for watching changes in + directories. *) diff --git a/vendors/irmin/src/irmin/version.ml b/vendors/irmin/src/irmin/version.ml new file mode 100644 index 0000000000000000000000000000000000000000..50da68aa26252ef6140b1179d96b0bb7988019b8 --- /dev/null +++ b/vendors/irmin/src/irmin/version.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let current = "%%VERSION%%" diff --git a/vendors/irmin/src/irmin/watch.ml b/vendors/irmin/src/irmin/watch.ml new file mode 100644 index 0000000000000000000000000000000000000000..55723d184f904ac7defbdb59ca29b1c6a9034625 --- /dev/null +++ b/vendors/irmin/src/irmin/watch.ml @@ -0,0 +1,326 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Watch_intf + +let src = Logs.Src.create "irmin.watch" ~doc:"Irmin watch notifications" + +module Log = (val Logs.src_log src : Logs.LOG) + +let none _ _ = + Printf.eprintf "Listen hook not set!\n%!"; + assert false + +let listen_dir_hook = ref none + +type hook = + int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t + +let set_listen_dir_hook (h : hook) = listen_dir_hook := h + +let id () = + let c = ref 0 in + fun () -> + incr c; + !c + +let global = id () +let workers_r = ref 0 +let workers () = !workers_r + +let scheduler () = + let p = ref None in + let niet () = () in + let c = ref niet in + let push elt = + match !p with + | Some p -> p elt + | None -> + let stream, push = Lwt_stream.create () in + incr workers_r; + Lwt.async (fun () -> + (* FIXME: we would like to skip some updates if more recent ones + are at the back of the queue. *) + Lwt_stream.iter_s (fun f -> f ()) stream); + p := Some push; + (c := fun () -> push None); + push elt + in + let clean () = + !c (); + decr workers_r; + c := niet; + p := None + in + let enqueue v = push (Some v) in + (clean, enqueue) + +module Make (K : sig + type t + + val t : t Type.t +end) (V : sig + type t + + val t : t Type.t +end) = +struct + type key = K.t + type value = V.t + type watch = int + + module KMap = Map.Make (struct + type t = K.t + + let compare = Type.(unstage (compare K.t)) + end) + + module IMap = Map.Make (struct + type t = int + + let compare (x : int) (y : int) = compare x y + end) + + type key_handler = value Diff.t -> unit Lwt.t + type all_handler = key -> value Diff.t -> unit Lwt.t + + let pp_value = Type.pp V.t + let equal_opt_values = Type.(unstage (equal (option V.t))) + let equal_keys = Type.(unstage (equal K.t)) + + type t = { + id : int; + (* unique watch manager id. *) + lock : Lwt_mutex.t; + (* protect [keys] and [glob]. *) + mutable next : int; + (* next id, to identify watch handlers. *) + mutable keys : (key * value option * key_handler) IMap.t; + (* key handlers. *) + mutable glob : (value KMap.t * all_handler) IMap.t; + (* global handlers. *) + enqueue : (unit -> unit Lwt.t) -> unit; + (* enqueue notifications. *) + clean : unit -> unit; + (* destroy the notification thread. *) + mutable listeners : int; + (* number of listeners. *) + mutable stop_listening : unit -> unit Lwt.t; + (* clean-up listen resources. *) + mutable notifications : int; (* number of notifcations. *) + } + + let stats t = (IMap.cardinal t.keys, IMap.cardinal t.glob) + + let to_string t = + let k, a = stats t in + Printf.sprintf "[%d: %dk/%dg|%d]" t.id k a t.listeners + + let next t = + let id = t.next in + t.next <- id + 1; + id + + let is_empty t = IMap.is_empty t.keys && IMap.is_empty t.glob + + let clear_unsafe t = + t.keys <- IMap.empty; + t.glob <- IMap.empty; + t.next <- 0 + + let clear t = + Lwt_mutex.with_lock t.lock (fun () -> + clear_unsafe t; + Lwt.return_unit) + + let v () = + let lock = Lwt_mutex.create () in + let clean, enqueue = scheduler () in + { + lock; + clean; + enqueue; + id = global (); + next = 0; + keys = IMap.empty; + glob = IMap.empty; + listeners = 0; + stop_listening = (fun () -> Lwt.return_unit); + notifications = 0; + } + + let unwatch_unsafe t id = + [%log.debug "unwatch %s: id=%d" (to_string t) id]; + let glob = IMap.remove id t.glob in + let keys = IMap.remove id t.keys in + t.glob <- glob; + t.keys <- keys + + let unwatch t id = + Lwt_mutex.with_lock t.lock (fun () -> + unwatch_unsafe t id; + if is_empty t then t.clean (); + Lwt.return_unit) + + let mk old value = + match (old, value) with + | None, None -> assert false + | Some v, None -> `Removed v + | None, Some v -> `Added v + | Some x, Some y -> `Updated (x, y) + + let protect f () = + Lwt.catch f (fun e -> + [%log.err + "watch callback got: %a\n%s" Fmt.exn e (Printexc.get_backtrace ())]; + Lwt.return_unit) + + let pp_option = Fmt.option ~none:(Fmt.any "") + let pp_key = Type.pp K.t + + let notify_all_unsafe t key value = + let todo = ref [] in + let glob = + IMap.fold + (fun id ((init, f) as arg) acc -> + let fire old_value = + todo := + protect (fun () -> + [%log.debug + "notify-all[%d.%d:%a]: %d firing! (%a -> %a)" t.id id pp_key + key t.notifications (pp_option pp_value) old_value + (pp_option pp_value) value]; + t.notifications <- t.notifications + 1; + f key (mk old_value value)) + :: !todo; + let init = + match value with + | None -> KMap.remove key init + | Some v -> KMap.add key v init + in + IMap.add id (init, f) acc + in + let old_value = + try Some (KMap.find key init) with Not_found -> None + in + if equal_opt_values old_value value then ( + [%log.debug + "notify-all[%d:%d:%a]: same value, skipping." t.id id pp_key key]; + IMap.add id arg acc) + else fire old_value) + t.glob IMap.empty + in + t.glob <- glob; + match !todo with + | [] -> () + | ts -> t.enqueue (fun () -> Lwt_list.iter_p (fun x -> x ()) ts) + + let notify_key_unsafe t key value = + let todo = ref [] in + let keys = + IMap.fold + (fun id ((k, old_value, f) as arg) acc -> + if not (equal_keys key k) then IMap.add id arg acc + else if equal_opt_values value old_value then ( + [%log.debug + "notify-key[%d.%d:%a]: same value, skipping." t.id id pp_key key]; + IMap.add id arg acc) + else ( + todo := + protect (fun () -> + [%log.debug + "notify-key[%d:%d:%a] %d firing! (%a -> %a)" t.id id pp_key + key t.notifications (pp_option pp_value) old_value + (pp_option pp_value) value]; + t.notifications <- t.notifications + 1; + f (mk old_value value)) + :: !todo; + IMap.add id (k, value, f) acc)) + t.keys IMap.empty + in + t.keys <- keys; + match !todo with + | [] -> () + | ts -> t.enqueue (fun () -> Lwt_list.iter_p (fun x -> x ()) ts) + + let notify t key value = + Lwt_mutex.with_lock t.lock (fun () -> + if is_empty t then Lwt.return_unit + else ( + notify_all_unsafe t key value; + notify_key_unsafe t key value; + Lwt.return_unit)) + + let watch_key_unsafe t key ?init f = + let id = next t in + [%log.debug "watch-key %s: id=%d" (to_string t) id]; + t.keys <- IMap.add id (key, init, f) t.keys; + id + + let watch_key t key ?init f = + Lwt_mutex.with_lock t.lock (fun () -> + let id = watch_key_unsafe t ?init key f in + Lwt.return id) + + let kmap_of_alist l = + List.fold_left (fun map (k, v) -> KMap.add k v map) KMap.empty l + + let watch_unsafe t ?(init = []) f = + let id = next t in + [%log.debug "watch %s: id=%d" (to_string t) id]; + t.glob <- IMap.add id (kmap_of_alist init, f) t.glob; + id + + let watch t ?init f = + Lwt_mutex.with_lock t.lock (fun () -> + let id = watch_unsafe t ?init f in + Lwt.return id) + + let listen_dir t dir ~key ~value = + let init () = + if t.listeners = 0 then ( + [%log.debug "%s: start listening to %s" (to_string t) dir]; + let+ f = + !listen_dir_hook t.id dir (fun file -> + match key file with + | None -> Lwt.return_unit + | Some key -> + let rec read n = + let* value = value key in + let n' = t.notifications in + if n = n' then notify t key value + else ( + [%log.debug "Stale event, trying reading again"]; + read n') + in + read t.notifications) + in + t.stop_listening <- f) + else ( + [%log.debug "%s: already listening on %s" (to_string t) dir]; + Lwt.return_unit) + in + init () >|= fun () -> + t.listeners <- t.listeners + 1; + function + | () -> + if t.listeners > 0 then t.listeners <- t.listeners - 1; + if t.listeners <> 0 then Lwt.return_unit + else ( + [%log.debug "%s: stop listening to %s" (to_string t) dir]; + t.stop_listening ()) +end diff --git a/vendors/irmin/src/irmin/watch.mli b/vendors/irmin/src/irmin/watch.mli new file mode 100644 index 0000000000000000000000000000000000000000..38f6002ff3285314f563b056243e70062616893b --- /dev/null +++ b/vendors/irmin/src/irmin/watch.mli @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [Watch] provides helpers to register event notifications on read-write + stores. *) + +include Watch_intf.Sigs +(** @inline *) diff --git a/vendors/irmin/src/irmin/watch_intf.ml b/vendors/irmin/src/irmin/watch_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..fad0d17a1431c90c8848b145261aff2093ba96b0 --- /dev/null +++ b/vendors/irmin/src/irmin/watch_intf.ml @@ -0,0 +1,96 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Watch Helpers} *) + + type key + (** The type for store keys. *) + + type value + (** The type for store values. *) + + type watch + (** The type for watch handlers. *) + + type t + (** The type for watch state. *) + + val stats : t -> int * int + (** [stats t] is a tuple [(k,a)] represeting watch stats. [k] is the number of + single key watchers for the store [t] and [a] the number of global + watchers for [t]. *) + + val notify : t -> key -> value option -> unit Lwt.t + (** Notify all listeners in the given watch state that a key has changed, with + the new value associated to this key. [None] means the key has been + removed. *) + + val v : unit -> t + (** Create a watch state. *) + + val clear : t -> unit Lwt.t + (** Clear all register listeners in the given watch state. *) + + val watch_key : + t -> key -> ?init:value -> (value Diff.t -> unit Lwt.t) -> watch Lwt.t + (** Watch a given key for changes. More efficient than {!watch}. *) + + val watch : + t -> + ?init:(key * value) list -> + (key -> value Diff.t -> unit Lwt.t) -> + watch Lwt.t + (** Add a watch handler. To watch a specific key, use {!watch_key} which is + more efficient. *) + + val unwatch : t -> watch -> unit Lwt.t + (** Remove a watch handler. *) + + val listen_dir : + t -> + string -> + key:(string -> key option) -> + value:(key -> value option Lwt.t) -> + (unit -> unit Lwt.t) Lwt.t + (** Register a thread looking for changes in the given directory and return a + function to stop watching and free up resources. *) +end + +module type Sigs = sig + module type S = S + (** The signature for watch helpers. *) + + val workers : unit -> int + (** [workers ()] is the number of background worker threads managing event + notification currently active. *) + + type hook = + int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t + (** The type for watch hooks. *) + + val none : hook + (** [none] is the hooks which asserts false. *) + + val set_listen_dir_hook : hook -> unit + (** Register a function which looks for file changes in a directory and return + a function to stop watching. It is probably best to use + {!Irmin_watcher.hook} there. By default, it uses {!none}. *) + + (** [Make] builds an implementation of watch helpers. *) + module Make (K : Type.S) (V : Type.S) : + S with type key = K.t and type value = V.t +end diff --git a/vendors/irmin/src/libirmin/commit.ml b/vendors/irmin/src/libirmin/commit.ml new file mode 100644 index 0000000000000000000000000000000000000000..e796c0c2a13f3f20559a0237803fd1283b4c6833 --- /dev/null +++ b/vendors/irmin/src/libirmin/commit.ml @@ -0,0 +1,160 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Cstubs_inverted.INTERNAL) = struct + open Util.Make (I) + + let () = + fn "commit_info" + (repo @-> commit @-> returning info) + (fun (type repo) repo commit -> + with_repo' repo info + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let commit = Root.get_commit (module Store) commit in + Root.create_info (module Store) (Store.Commit.info commit))) + + let () = + fn "commit_hash" + (repo @-> commit @-> returning hash) + (fun (type repo) repo commit -> + with_repo' repo hash + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let commit = Root.get_commit (module Store) commit in + Root.create_hash (module Store) (Store.Commit.hash commit))) + + let () = + fn "commit_key" + (repo @-> commit @-> returning commit_key) + (fun (type repo) repo commit -> + with_repo' repo commit_key + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let commit = Root.get_commit (module Store) commit in + Root.create_commit_key (module Store) (Store.Commit.key commit))) + + let () = + fn "commit_of_hash" + (repo @-> hash @-> returning commit) + (fun (type repo) repo hash -> + with_repo' repo commit + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + let hash = Root.get_hash (module Store) hash in + let c = run (Store.Commit.of_hash repo hash) in + match c with + | Some c -> Root.create_commit (module Store) c + | None -> null commit)) + + let () = + fn "commit_of_key" + (repo @-> commit_key @-> returning commit) + (fun (type repo) repo hash -> + with_repo' repo commit + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + let hash = Root.get_commit_key (module Store) hash in + let c = run (Store.Commit.of_key repo hash) in + match c with + | Some c -> Root.create_commit (module Store) c + | None -> null commit)) + + let () = + fn "commit_new" + (repo @-> ptr commit @-> uint64_t @-> tree @-> info @-> returning commit) + (fun (type repo) repo parents n tree info -> + with_repo' repo commit + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + let n = UInt64.to_int n in + let parents = + if is_null parents || n = 0 then [] + else + CArray.from_ptr parents n + |> CArray.to_list + |> List.map (Root.get_commit (module Store)) + |> List.map Store.Commit.key + in + let tree = Root.get_tree (module Store) tree in + let info = Root.get_info (module Store) info in + let commit = run (Store.Commit.v repo ~parents ~info tree) in + Root.create_commit (module Store) commit)) + + let () = + let open Lwt.Infix in + fn "commit_parents" + (repo @-> commit @-> returning commit_array) + (fun (type repo) repo commit -> + with_repo' repo commit_array + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + let commit = Root.get_commit (module Store) commit in + let parents = Store.Commit.parents commit in + let parents = + run + (Lwt_list.filter_map_s + (fun x -> + Store.Commit.of_key repo x >|= function + | None -> None + | Some x -> Some x) + parents) + in + Root.create_commit_array (module Store) parents)) + + let () = + fn "commit_equal" + (repo @-> commit @-> commit @-> returning bool) + (fun (type repo) repo a b -> + with_repo repo false + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + let a = Root.get_commit (module Store) a in + let b = Root.get_commit (module Store) b in + Irmin.Type.(unstage (equal (Store.commit_t repo))) a b)) + + let () = + fn "commit_tree" + (repo @-> commit @-> returning tree) + (fun (type repo) repo commit -> + with_repo' repo tree + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let commit = Root.get_commit (module Store) commit in + Root.create_tree (module Store) (Store.Commit.tree commit))) + + let () = + fn "commit_array_length" + (repo @-> commit_array @-> returning uint64_t) + (fun (type repo) repo p -> + with_repo repo UInt64.zero + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let arr = Root.get_commit_array (module Store) p in + UInt64.of_int (Array.length arr))) + + let () = + fn "commit_array_get" + (repo @-> commit_array @-> uint64_t @-> returning commit) + (fun (type repo) repo p i -> + with_repo' repo commit + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let i = UInt64.to_int i in + let arr = Root.get_commit_array (module Store) p in + if i >= Array.length arr then failwith "index out of bounds" + else + let x = Array.unsafe_get arr i in + Root.create_commit (module Store) x)) + + let () = fn "commit_array_free" (commit_array @-> returning void) free + let () = fn "commit_free" (commit @-> returning void) free + let () = fn "commit_key_free" (commit_key @-> returning void) free +end diff --git a/vendors/irmin/src/libirmin/config.ml b/vendors/irmin/src/libirmin/config.ml new file mode 100644 index 0000000000000000000000000000000000000000..29fab1e0d6d2775ba5a1e56606a0868e098d2da3 --- /dev/null +++ b/vendors/irmin/src/libirmin/config.ml @@ -0,0 +1,150 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Cstubs_inverted.INTERNAL) = struct + open Util.Make (I) + + let () = + fn "log_level" + (string_opt @-> returning bool) + (fun level -> + try + match level with + | None -> + Logs.set_level None; + true + | Some level -> ( + Fmt_tty.setup_std_outputs (); + Logs.set_reporter (Logs_fmt.reporter ()); + match Logs.level_of_string level with + | Error _ -> false + | Ok level -> + Logs.set_level level; + true) + with _ -> false) + + let () = + fn "config_pack" + (string_opt @-> string_opt @-> returning config) + (fun hash contents -> + try + let hash = Option.map Irmin_cli.Resolver.Hash.find hash in + let c : config = + Irmin_cli.Resolver.load_config ~store:"pack" ?hash ?contents () + in + Root.create_config c + with _ -> null config) + + let () = + fn "config_tezos" + (void @-> returning config) + (fun () -> + try + let c : config = Irmin_cli.Resolver.load_config ~store:"tezos" () in + Root.create_config c + with _ -> null config) + + let () = + fn "config_git" + (string_opt @-> returning config) + (fun contents -> + try + let c = Irmin_cli.Resolver.load_config ~store:"git" ?contents () in + Root.create_config c + with _ -> null config) + + let () = + fn "config_git_mem" + (string_opt @-> returning config) + (fun contents -> + try + let c = + Irmin_cli.Resolver.load_config ~store:"git-mem" ?contents () + in + Root.create_config c + with _ -> null config) + + let () = + fn "config_fs" + (string_opt @-> string_opt @-> returning config) + (fun hash contents -> + try + let hash = Option.map Irmin_cli.Resolver.Hash.find hash in + let c = + Irmin_cli.Resolver.load_config ~store:"irf" ?hash ?contents () + in + Root.create_config c + with _ -> null config) + + let () = + fn "config_mem" + (string_opt @-> string_opt @-> returning config) + (fun hash contents -> + try + let hash = Option.map Irmin_cli.Resolver.Hash.find hash in + let c = + Irmin_cli.Resolver.load_config ~store:"mem" ?hash ?contents () + in + Root.create_config c + with _ -> null config) + + let () = fn "config_free" (config @-> returning void) free + + let () = + fn "config_set" + (config @-> string @-> ty @-> value @-> returning bool) + (fun (type a) c key ty value -> + try + let (s, config) : config = Root.get_config c in + let (module S) = Irmin_cli.Resolver.Store.generic_keyed s in + let k = find_config_key config key in + let ok, config = + match k with + | None -> (false, config) + | Some (Irmin.Backend.Conf.K k) -> + let t : a Irmin.Type.t = Root.get_ty ty in + if type_name t <> type_name (Irmin.Backend.Conf.ty k) then + (false, config) + else + let value = Root.get_value value in + (true, Irmin.Backend.Conf.add config k value) + in + Root.set_config c (s, config); + ok + with _ -> false) + + let () = + fn "config_set_root" + (config @-> string @-> returning bool) + (fun c path -> + try + let (s, config) : config = Root.get_config c in + let (module S) = Irmin_cli.Resolver.Store.generic_keyed s in + let k = find_config_key config "root" in + let ok, config = + match k with + | None -> (false, config) + | Some (Irmin.Backend.Conf.K k) -> + let path = + Irmin.Type.of_string (Irmin.Backend.Conf.ty k) path + |> Result.get_ok + in + (true, Irmin.Backend.Conf.add config k path) + in + Root.set_config c (s, config); + ok + with _ -> false) +end diff --git a/vendors/irmin/src/libirmin/dune b/vendors/irmin/src/libirmin/dune new file mode 100644 index 0000000000000000000000000000000000000000..1672aa7e6927ed7d3a1c3cad029c13fd37254ca9 --- /dev/null +++ b/vendors/irmin/src/libirmin/dune @@ -0,0 +1,5 @@ +(library + (name libirmin_bindings) + (libraries irmin-cli irmin.unix ctypes.foreign) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/libirmin/gen/dune b/vendors/irmin/src/libirmin/gen/dune new file mode 100644 index 0000000000000000000000000000000000000000..52692a0b2060d2e69093dbbbd35af324bb2f0204 --- /dev/null +++ b/vendors/irmin/src/libirmin/gen/dune @@ -0,0 +1,4 @@ +(executable + (name generate) + (modules generate) + (libraries libirmin_bindings)) diff --git a/vendors/irmin/src/libirmin/gen/generate.ml b/vendors/irmin/src/libirmin/gen/generate.ml new file mode 100644 index 0000000000000000000000000000000000000000..90943b7f14954b5506c98346c2593a2ba42e0d17 --- /dev/null +++ b/vendors/irmin/src/libirmin/gen/generate.ml @@ -0,0 +1,98 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let generate dirname = + let prefix = "irmin" in + let path basename = Filename.concat dirname basename in + let ml_fd = open_out (path "irmin_bindings.ml") in + let c_fd = open_out (path "irmin.c") in + let h_fd = open_out (path "irmin.h") in + let stubs = (module Libirmin_bindings.Stubs : Cstubs_inverted.BINDINGS) in + let writeln fd s = output_string fd (s ^ "\n") in + let types fd names = + List.iter + (fun n -> writeln fd (Printf.sprintf "typedef struct %s %s;" n n)) + names + in + (* Generate the ML module that links in the generated C. *) + Cstubs_inverted.write_ml (Format.formatter_of_out_channel ml_fd) ~prefix stubs; + + (* Generate the C source file that exports OCaml functions. *) + Format.fprintf + (Format.formatter_of_out_channel c_fd) + "#include \"irmin.h\"@\n%a" + (Cstubs_inverted.write_c ~prefix) + stubs; + writeln c_fd + {| +#ifndef IRMIN_NO_INIT +static char *_libirmin_args[] = {"libirmin", NULL}; +void irmin_init(void){ + caml_startup(_libirmin_args); +} +#ifdef __APPLE__ +__attribute__((section("__DATA,__mod_init_func"))) typeof(irmin_init) *p_irmin_init = irmin_init; +#else +__attribute__((section(".init_array"))) void (*p_irmin_init)(void) = irmin_init; +#endif +#endif + |}; + + (* Generate the C header file that exports OCaml functions. *) + writeln h_fd "#pragma once"; + writeln h_fd "#include "; + writeln h_fd "#include "; + types h_fd + [ + "IrminType"; + "IrminValue"; + "IrminMetadata"; + "IrminContents"; + "IrminConfig"; + "IrminRepo"; + "Irmin"; + "IrminPath"; + "IrminCommitKey"; + "IrminKindedKey"; + "IrminTree"; + "IrminCommit"; + "IrminInfo"; + "IrminHash"; + "IrminString"; + "IrminPathArray"; + "IrminCommitArray"; + "IrminBranchArray"; + "IrminRemote"; + ]; + writeln h_fd "void caml_startup(char *argv[]);"; + writeln h_fd "void caml_shutdown();"; + + Cstubs_inverted.write_c_header + (Format.formatter_of_out_channel h_fd) + ~prefix stubs; + writeln h_fd + {| +#ifndef IRMIN_NO_AUTO +static void _irmin_cleanup(void *p) { if (p) { irmin_free(*(Irmin**)p); p = (void*)0;} }; +#define AUTO __attribute__((cleanup(_irmin_cleanup))) +#endif + |}; + + close_out h_fd; + close_out c_fd; + close_out ml_fd + +let () = generate Sys.argv.(1) diff --git a/vendors/irmin/src/libirmin/info.ml b/vendors/irmin/src/libirmin/info.ml new file mode 100644 index 0000000000000000000000000000000000000000..dfe46d4e668cdb892b547340fcd17382b3dcdf84 --- /dev/null +++ b/vendors/irmin/src/libirmin/info.ml @@ -0,0 +1,69 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Cstubs_inverted.INTERNAL) = struct + open Util.Make (I) + + let () = + fn "info_new" + (repo @-> string_opt @-> string @-> returning info) + (fun (type repo) repo author message -> + with_repo' repo info + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let module Info = Irmin_unix.Info (Store.Info) in + let info : Info.t = Info.v ?author "%s" message () in + Root.create_info (module Store) info)) + + let () = + fn "info_update" + (repo @-> info @-> string_opt @-> string @-> returning void) + (fun (type repo) repo info author message -> + with_repo repo () + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let module Info = Irmin_unix.Info (Store.Info) in + Root.set_info (module Store) info (Info.v ?author "%s" message ()))) + + let () = + fn "info_message" + (repo @-> info @-> returning irmin_string) + (fun (type repo) repo info -> + with_repo' repo irmin_string + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let info = Root.get_info (module Store) info in + let s = Store.Info.message info in + Root.create_string s)) + + let () = + fn "info_author" + (repo @-> info @-> returning irmin_string) + (fun (type repo) repo info -> + with_repo' repo irmin_string + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let info = Root.get_info (module Store) info in + let s = Store.Info.author info in + Root.create_string s)) + + let () = + fn "info_date" + (repo @-> info @-> returning int64_t) + (fun (type repo) repo info -> + with_repo repo (-1L) + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let info = Root.get_info (module Store) info in + Store.Info.date info)) + + let () = fn "info_free" (info @-> returning void) free +end diff --git a/vendors/irmin/src/libirmin/lib/dune b/vendors/irmin/src/libirmin/lib/dune new file mode 100644 index 0000000000000000000000000000000000000000..dbfd80157a6f6b15db3a3f91a6ad0a71f4dc67dc --- /dev/null +++ b/vendors/irmin/src/libirmin/lib/dune @@ -0,0 +1,31 @@ +(rule + (targets irmin_bindings.ml irmin.c irmin.h) + (deps + (:gen ../gen/generate.exe)) + (action + (run %{gen} .))) + +(executable + (name libirmin) + (package libirmin) + (public_name libirmin) + (libraries libirmin_bindings) + (modes + (native shared_object) + native) + (modules libirmin irmin_bindings) + (foreign_stubs + (language c) + (names irmin))) + +(install + (package libirmin) + (section lib) + (files + (irmin.h as include/irmin.h) + (libirmin.so as lib/libirmin.so))) + +(env + (dev + (flags + (:standard -w -unused-var-strict)))) diff --git a/vendors/irmin/src/libirmin/lib/libirmin.ml b/vendors/irmin/src/libirmin/lib/libirmin.ml new file mode 100644 index 0000000000000000000000000000000000000000..27dbd2d086f37b2ad2f64c3447016590c8f8f36d --- /dev/null +++ b/vendors/irmin/src/libirmin/lib/libirmin.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Libirmin_bindings.Stubs (Irmin_bindings) diff --git a/vendors/irmin/src/libirmin/libirmin_bindings.ml b/vendors/irmin/src/libirmin/libirmin_bindings.ml new file mode 100644 index 0000000000000000000000000000000000000000..6a2dc1f584c0e1b39212a972bb98c698b813507e --- /dev/null +++ b/vendors/irmin/src/libirmin/libirmin_bindings.ml @@ -0,0 +1,27 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Stubs (I : Cstubs_inverted.INTERNAL) = struct + include Type.Make (I) + include Value.Make (I) + include Info.Make (I) + include Config.Make (I) + include Store.Make (I) + include Tree.Make (I) + include Repo.Make (I) + include Commit.Make (I) + include Path.Make (I) +end diff --git a/vendors/irmin/src/libirmin/path.ml b/vendors/irmin/src/libirmin/path.ml new file mode 100644 index 0000000000000000000000000000000000000000..80d38dae2659e2d4bd7e6129124e7854d40433c5 --- /dev/null +++ b/vendors/irmin/src/libirmin/path.ml @@ -0,0 +1,123 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Cstubs_inverted.INTERNAL) = struct + open Util.Make (I) + + let () = + fn "path" + (repo @-> ptr string_opt @-> returning path) + (fun (type repo) repo arr -> + with_repo' repo path + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let rec loop i acc = + if is_null arr then acc + else + match !@(arr +@ i) with + | None -> List.rev acc + | Some x -> loop (i + 1) (x :: acc) + in + let l = loop 0 [] in + let l = + List.map + (fun x -> Irmin.Type.of_string Store.step_t x |> Result.get_ok) + l + in + Store.Path.v l |> Root.create_path (module Store))) + + let () = + fn "path_of_string" + (repo @-> ptr char @-> int64_t @-> returning path) + (fun (type repo) repo s length -> + with_repo' repo path + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let length = get_length length s in + let s = string_from_ptr s ~length in + match Irmin.Type.of_string Store.Path.t s with + | Ok p -> Root.create_path (module Store) p + | Error (`Msg e) -> failwith e)) + + let () = + fn "path_empty" + (repo @-> returning path) + (fun (type repo) repo -> + with_repo' repo path + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_path (module Store) Store.Path.empty)) + + let () = + fn "path_to_string" + (repo @-> path @-> returning irmin_string) + (fun (type repo) repo p -> + with_repo' repo irmin_string + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let path = Root.get_path (module Store) p in + let s = Irmin.Type.to_string Store.Path.t path in + Root.create_string s)) + + let () = + fn "path_parent" + (repo @-> path @-> returning path) + (fun (type repo) repo p -> + with_repo' repo path + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let p = Root.get_path (module Store) p in + let p = Store.Path.rdecons p |> Option.map fst in + match p with + | Some p -> Root.create_path (module Store) p + | None -> null path)) + + let () = + fn "path_append" + (repo @-> path @-> ptr char @-> int64_t @-> returning path) + (fun (type repo) repo p s length -> + with_repo' repo path + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let length = get_length length s in + let p = Root.get_path (module Store) p in + let s = string_from_ptr s ~length in + match Irmin.Type.of_string Store.step_t s with + | Ok s -> Root.create_path (module Store) (Store.Path.rcons p s) + | Error (`Msg e) -> failwith e)) + + let () = + fn "path_append_path" + (repo @-> path @-> path @-> returning path) + (fun (type repo) repo p s -> + with_repo' repo path + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let rec concat_paths a b = + match Store.Path.decons b with + | Some (step, path) -> concat_paths (Store.Path.rcons a step) path + | None -> a + in + let path = Root.get_path (module Store) p in + let path' = Root.get_path (module Store) s in + let dest = concat_paths path path' in + Root.create_path (module Store) dest)) + + let () = + fn "path_equal" + (repo @-> path @-> path @-> returning bool) + (fun (type repo) repo a b -> + with_repo repo false + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let a = Root.get_path (module Store) a in + let b = Root.get_path (module Store) b in + Irmin.Type.(unstage (equal Store.path_t)) a b)) + + let () = fn "path_free" (path @-> returning void) free +end diff --git a/vendors/irmin/src/libirmin/repo.ml b/vendors/irmin/src/libirmin/repo.ml new file mode 100644 index 0000000000000000000000000000000000000000..417bc160ed945e95d522dc796d9c679bf62ac123 --- /dev/null +++ b/vendors/irmin/src/libirmin/repo.ml @@ -0,0 +1,193 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Cstubs_inverted.INTERNAL) = struct + open Util.Make (I) + + let () = + fn "repo_new" + (config @-> returning repo) + (fun config -> + let (s, config) : config = Root.get_config config in + let (module Store) = Irmin_cli.Resolver.Store.generic_keyed s in + let remote = Irmin_cli.Resolver.Store.remote s in + let repo : Store.repo = run (Store.Repo.v config) in + Root.create_repo + (module Store) + { + error = None; + repo_mod = + (module Store : Irmin.Generic_key.S with type repo = Store.repo); + repo; + remote; + }) + + let () = + fn "repo_branches" + (repo @-> returning branch_array) + (fun (type repo) repo -> + with_repo' repo branch_array + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + let b = run (Store.Repo.branches repo) in + Root.create_branch_array (module Store) b)) + + let () = + fn "branch_array_length" + (repo @-> branch_array @-> returning uint64_t) + (fun (type repo) repo p -> + with_repo repo UInt64.zero + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let arr = Root.get_branch_array (module Store) p in + UInt64.of_int (Array.length arr))) + + let () = + fn "branch_array_get" + (repo @-> branch_array @-> uint64_t @-> returning irmin_string) + (fun (type repo) repo p i -> + with_repo' repo irmin_string + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let i = UInt64.to_int i in + let arr = Root.get_branch_array (module Store) p in + if i >= Array.length arr then failwith "index out of bounds" + else + let x = Array.unsafe_get arr i in + Root.create_string (Irmin.Type.to_string Store.Branch.t x))) + + let () = + fn "hash_equal" + (repo @-> hash @-> hash @-> returning bool) + (fun (type repo) repo a b -> + with_repo repo false + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let a = Root.get_hash (module Store) a in + let b = Root.get_hash (module Store) b in + Irmin.Type.(unstage (equal Store.hash_t)) a b)) + + let () = + fn "contents_hash" + (repo @-> contents @-> returning hash) + (fun (type repo) repo a -> + with_repo' repo hash + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let a = Root.get_contents (module Store) a in + Root.create_hash (module Store) (Store.Contents.hash a))) + + let () = + fn "contents_of_hash" + (repo @-> hash @-> returning contents) + (fun (type repo) repo a -> + with_repo' repo contents + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + let a = Root.get_hash (module Store) a in + let c = run @@ Store.Contents.of_hash repo a in + match c with + | Some c -> Root.create_contents (module Store) c + | None -> null contents)) + + let () = + fn "contents_of_key" + (repo @-> kinded_key @-> returning contents) + (fun (type repo) repo a -> + with_repo' repo contents + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + let a = Root.get_kinded_key (module Store) a in + match a with + | `Contents (a, _) -> ( + let c = run @@ Store.Contents.of_key repo a in + match c with + | Some c -> Root.create_contents (module Store) c + | None -> null contents) + | `Node _ -> null contents)) + + let () = + fn "contents_to_string" + (repo @-> contents @-> returning irmin_string) + (fun (type repo) repo contents -> + with_repo' repo irmin_string + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let contents = Root.get_contents (module Store) contents in + let s = Irmin.Type.to_string Store.contents_t contents in + Root.create_string s)) + + let () = + fn "contents_of_string" + (repo @-> ptr char @-> int64_t @-> returning contents) + (fun (type repo) repo s length -> + with_repo' repo contents + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let length = get_length length s in + let s = string_from_ptr s ~length in + let hash = Irmin.Type.of_string Store.contents_t s in + match hash with + | Ok hash -> Root.create_contents (module Store) hash + | Error (`Msg e) -> failwith e)) + + let () = + fn "hash_to_string" + (repo @-> hash @-> returning irmin_string) + (fun (type repo) repo hash -> + with_repo' repo irmin_string + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let hash = Root.get_hash (module Store) hash in + let s = Irmin.Type.to_string Store.hash_t hash in + Root.create_string s)) + + let () = + fn "hash_of_string" + (repo @-> ptr char @-> int64_t @-> returning hash) + (fun (type repo) repo s length -> + with_repo' repo hash + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let length = get_length length s in + let s = string_from_ptr s ~length in + let h = Irmin.Type.of_string Store.Hash.t s in + match h with + | Ok h -> Root.create_hash (module Store) h + | Error (`Msg e) -> failwith e)) + + let () = + fn "metadata_default" + (repo @-> returning metadata) + (fun (type repo) repo -> + with_repo' repo metadata + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_metadata (module Store) Store.Metadata.default)) + + let () = + fn "repo_has_error" + (repo @-> returning bool) + (fun repo -> + let r = Root.get_repo repo in + Option.is_some r.error) + + let () = + fn "repo_get_error" + (repo @-> returning irmin_string) + (fun repo -> + let r = Root.get_repo repo in + match r.error with + | Some x -> Root.create_string x + | None -> null irmin_string) + + let () = fn "hash_free" (hash @-> returning void) free + let () = fn "branch_array_free" (branch_array @-> returning void) free + let () = fn "repo_free" (repo @-> returning void) free + let () = fn "metadata_free" (metadata @-> returning void) free + let () = fn "contents_free" (contents @-> returning void) free +end diff --git a/vendors/irmin/src/libirmin/store.ml b/vendors/irmin/src/libirmin/store.ml new file mode 100644 index 0000000000000000000000000000000000000000..be17aa7c2404f6b68772787bc8de40ccd6a18e05 --- /dev/null +++ b/vendors/irmin/src/libirmin/store.ml @@ -0,0 +1,450 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Cstubs_inverted.INTERNAL) = struct + open Util.Make (I) + + let () = + fn "main" + (repo @-> returning store) + (fun (type repo) repo' -> + let r = Root.to_voidp repo repo' in + with_repo' repo' store + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + Root.create_store + (module Store) + { + repo = r; + store_mod = + (module Store : Irmin.Generic_key.S with type t = Store.t); + store = run (Store.main repo); + })) + + let () = + fn "of_branch" + (repo @-> string @-> returning store) + (fun (type repo) repo' name -> + let r = Root.to_voidp repo repo' in + with_repo' repo' store + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + match Irmin.Type.of_string Store.Branch.t name with + | Error (`Msg err) -> failwith err + | Ok branch -> + Root.create_store + (module Store) + { + repo = r; + store_mod = + (module Store : Irmin.Generic_key.S with type t = Store.t); + store = run (Store.of_branch repo branch); + })) + + let () = + fn "of_commit" + (repo @-> commit @-> returning store) + (fun (type repo) repo' commit -> + let r = Root.to_voidp repo repo' in + with_repo' repo' store + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let commit = Root.get_commit (module Store) commit in + Root.create_store + (module Store) + { + repo = r; + store_mod = + (module Store : Irmin.Generic_key.S with type t = Store.t); + store = run (Store.of_commit commit); + })) + + let () = + fn "get_head" + (store @-> returning commit) + (fun (type t) store -> + with_store' store commit + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let c = run (Store.Head.find store) in + match c with + | None -> null commit + | Some x -> Root.create_commit (module Store) x)) + + let () = + fn "set_head" + (store @-> commit @-> returning void) + (fun (type t) store commit -> + with_store store () + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let commit : Store.commit = Root.get_commit (module Store) commit in + run (Store.Head.set store commit))) + + let () = + fn "fast_forward" + (store @-> commit @-> returning bool) + (fun (type t) store commit -> + with_store store false + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let commit : Store.commit = Root.get_commit (module Store) commit in + let res = run (Store.Head.fast_forward store commit) in + match res with + | Ok () -> true + | Error e -> failwith (Irmin.Type.to_string Store.ff_error_t e))) + + let () = + fn "merge_with_branch" + (store @-> string @-> info @-> returning bool) + (fun (type t) store branch info -> + with_store store false + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let info = Root.get_info (module Store) info in + let branch = + Irmin.Type.of_string Store.branch_t branch |> Result.get_ok + in + let res = + run (Store.merge_with_branch store branch ~info:(fun () -> info)) + in + match res with + | Ok () -> true + | Error e -> + let s = Irmin.Type.to_string Irmin.Merge.conflict_t e in + failwith s)) + + let () = + fn "merge_with_commit" + (store @-> commit @-> info @-> returning bool) + (fun (type t) store commit info -> + with_store store false + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let info = Root.get_info (module Store) info in + let commit = Root.get_commit (module Store) commit in + let res = + run (Store.merge_with_commit store commit ~info:(fun () -> info)) + in + match res with + | Ok () -> true + | Error e -> + let s = Irmin.Type.to_string Irmin.Merge.conflict_t e in + failwith s)) + + let () = + fn "merge_into" + (store @-> store @-> info @-> returning bool) + (fun (type t) store store1 info -> + with_store store false + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let store1 = Root.get_store store1 in + let info = Root.get_info (module Store) info in + let res = + run + (Store.merge_into ~into:store store1.store ~info:(fun () -> + info)) + in + match res with + | Ok () -> true + | Error e -> + let s = Irmin.Type.to_string Irmin.Merge.conflict_t e in + failwith s)) + + let () = + fn "set" + (store @-> path @-> contents @-> info @-> returning bool) + (fun (type t) store path value info -> + with_store store false + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let info = Root.get_info (module Store) info in + let path : Store.path = Root.get_path (module Store) path in + let value : Store.contents = + Root.get_contents (module Store) value + in + let x = run (Store.set store path value ~info:(fun () -> info)) in + match x with + | Ok () -> true + | Error e -> + let s = Irmin.Type.to_string Store.write_error_t e in + failwith s)) + + let () = + fn "test_and_set" + (store @-> path @-> contents @-> contents @-> info @-> returning bool) + (fun (type t) store path test set info -> + with_store store false + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let info = Root.get_info (module Store) info in + let path : Store.path = Root.get_path (module Store) path in + let test : Store.contents option = + if is_null test then None + else Some (Root.get_contents (module Store) test) + in + let set : Store.contents option = + if is_null set then None + else Some (Root.get_contents (module Store) set) + in + let x = + run + (Store.test_and_set store path ~test ~set ~info:(fun () -> info)) + in + match x with + | Ok () -> true + | Error e -> + let s = Irmin.Type.to_string Store.write_error_t e in + failwith s)) + + let () = + fn "test_and_set_tree" + (store @-> path @-> tree @-> tree @-> info @-> returning bool) + (fun (type t) store path test set info -> + with_store store false + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let info = Root.get_info (module Store) info in + let path : Store.path = Root.get_path (module Store) path in + let test : Store.tree option = + if is_null test then None + else Some (Root.get_tree (module Store) test) + in + let set : Store.tree option = + if is_null set then None + else Some (Root.get_tree (module Store) set) + in + let x = + run + (Store.test_and_set_tree store path ~test ~set ~info:(fun () -> + info)) + in + match x with + | Ok () -> true + | Error e -> + let s = Irmin.Type.to_string Store.write_error_t e in + failwith s)) + + let () = + fn "set_tree" + (store @-> path @-> tree @-> info @-> returning bool) + (fun (type t) store path tree info -> + with_store store false + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let info : Store.info = Root.get_info (module Store) info in + let path : Store.path = Root.get_path (module Store) path in + let tree' : Store.tree = Root.get_tree (module Store) tree in + let x = + run (Store.set_tree store path tree' ~info:(fun () -> info)) + in + match x with + | Ok () -> true + | Error e -> + let s = Irmin.Type.to_string Store.write_error_t e in + failwith s)) + + let () = + fn "find" + (store @-> path @-> returning contents) + (fun (type t) store path -> + with_store' store contents + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let path : Store.path = Root.get_path (module Store) path in + let x = run (Store.find store path) in + match x with + | Some x -> Root.create_contents (module Store) x + | None -> null contents)) + + let () = + fn "find_metadata" + (store @-> path @-> returning metadata) + (fun (type t) store path -> + with_store' store metadata + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let path : Store.path = Root.get_path (module Store) path in + let x = run (Store.find_all store path) in + match x with + | Some (_, m) -> Root.create_metadata (module Store) m + | None -> null metadata)) + + let () = + fn "find_tree" + (store @-> path @-> returning tree) + (fun (type t) store path -> + with_store' store tree + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let path : Store.path = Root.get_path (module Store) path in + let x : Store.tree option = run (Store.find_tree store path) in + match x with + | Some x -> Root.create_tree (module Store) x + | None -> null tree)) + + let () = + fn "remove" + (store @-> path @-> info @-> returning bool) + (fun (type t) store path info -> + with_store store false + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let module Info = Irmin_unix.Info (Store.Info) in + let info = Root.get_info (module Store) info in + let path : Store.path = Root.get_path (module Store) path in + match run (Store.remove store path ~info:(fun () -> info)) with + | Ok () -> true + | Error e -> + let s = Irmin.Type.to_string Store.write_error_t e in + failwith s)) + + let () = + fn "mem" + (store @-> path @-> returning bool) + (fun (type t) store path -> + with_store store false + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let path : Store.path = Root.get_path (module Store) path in + run (Store.mem store path))) + + let () = + fn "mem_tree" + (store @-> path @-> returning bool) + (fun (type t) store path -> + with_store store false + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let path : Store.path = Root.get_path (module Store) path in + run (Store.mem_tree store path))) + + let () = + fn "list" + (store @-> path @-> returning path_array) + (fun (type t) store path -> + with_store' store path_array + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let path : Store.path = Root.get_path (module Store) path in + let items = run (Store.list store path) in + let items = List.map (fun (k, _v) -> Store.Path.v [ k ]) items in + Root.create_path_array (module Store) items)) + + let () = + fn "path_array_length" + (repo @-> path_array @-> returning uint64_t) + (fun (type repo) repo p -> + with_repo repo UInt64.zero + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let arr = Root.get_path_array (module Store) p in + UInt64.of_int (Array.length arr))) + + let () = + fn "path_array_get" + (repo @-> path_array @-> uint64_t @-> returning path) + (fun (type repo) repo p i -> + with_repo' repo path + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let i = UInt64.to_int i in + let arr = Root.get_path_array (module Store) p in + if i >= Array.length arr then failwith "index out of bounds" + else + let x = Array.unsafe_get arr i in + Root.create_path (module Store) x)) + + let () = + fn "remote_store" + (store @-> returning remote) + (fun (type t) store -> + with_store' store remote + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + Root.create_remote (Irmin.remote_store (module Store) store))) + + let () = + fn "remote" + (repo @-> string @-> returning remote) + (fun (type repo) repo url -> + let r = Root.get_repo repo in + let remote_fn = r.remote in + with_repo' repo remote + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + match remote_fn with + | None -> + failwith "sync is not implemented for the selected backend" + | Some f -> Root.create_remote (run (f url)))) + + let () = + fn "remote_with_auth" + (repo @-> string @-> string @-> string_opt @-> returning remote) + (fun (type repo) repo url user token -> + let r = Root.get_repo repo in + let remote_fn = r.remote in + with_repo' repo remote + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + match remote_fn with + | None -> + failwith "sync is not implemented for the selected backend" + | Some f -> + let headers = Cohttp.Header.init () in + let headers = + match token with + | Some token -> + Cohttp.Header.add_authorization headers + (`Basic (user, token)) + | _ -> Cohttp.Header.add_authorization headers (`Other user) + in + Root.create_remote (run (f ~headers url)))) + + let () = + fn "fetch" + (store @-> int @-> remote @-> returning commit) + (fun (type t) store depth remote -> + with_store' store commit + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let module Sync = Irmin.Sync.Make (Store) in + let remote = + if is_null remote then failwith "Invalid remote" + else Root.get_remote remote + in + let depth = if depth <= 0 then None else Some depth in + match run (Sync.fetch_exn ?depth store remote) with + | `Empty -> null commit + | `Head head -> Root.create_commit (module Store) head)) + + let () = + fn "pull" + (store @-> int @-> remote @-> info @-> returning commit) + (fun (type t) store depth remote info -> + with_store' store commit + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let module Sync = Irmin.Sync.Make (Store) in + let remote = + if is_null remote then failwith "Invalid remote" + else Root.get_remote remote + in + let x = + if is_null info then `Set + else `Merge (fun () -> Root.get_info (module Store) info) + in + let depth = if depth <= 0 then None else Some depth in + match run (Sync.pull_exn ?depth store remote x) with + | `Empty -> null commit + | `Head head -> Root.create_commit (module Store) head)) + + let () = + fn "push" + (store @-> int @-> remote @-> returning commit) + (fun (type t) store depth remote -> + with_store' store commit + (fun (module Store : Irmin.Generic_key.S with type t = t) store -> + let module Sync = Irmin.Sync.Make (Store) in + let remote = + if is_null remote then failwith "Invalid remote" + else Root.get_remote remote + in + let depth = if depth <= 0 then None else Some depth in + match run (Sync.push_exn ?depth store remote) with + | `Empty -> null commit + | `Head head -> Root.create_commit (module Store) head)) + + let () = fn "remote_free" (remote @-> returning void) free + let () = fn "path_array_free" (path_array @-> returning void) free + let () = fn "free" (store @-> returning void) free +end diff --git a/vendors/irmin/src/libirmin/tree.ml b/vendors/irmin/src/libirmin/tree.ml new file mode 100644 index 0000000000000000000000000000000000000000..4160d643cbc3e48b99b0fa72803cbc339331e2b1 --- /dev/null +++ b/vendors/irmin/src/libirmin/tree.ml @@ -0,0 +1,242 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Cstubs_inverted.INTERNAL) = struct + open Util.Make (I) + + let () = + fn "tree_new" + (repo @-> returning tree) + (fun (type repo) repo -> + with_repo' repo tree + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_tree (module Store) (Store.Tree.empty ()))) + + let () = + fn "tree_of_contents" + (repo @-> contents @-> metadata @-> returning tree) + (fun (type repo) repo value metadata -> + with_repo' repo tree + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let metadata = + if is_null metadata then None + else Some (Root.get_metadata (module Store) metadata) + in + let value = Root.get_contents (module Store) value in + Root.create_tree + (module Store) + (Store.Tree.of_contents ?metadata value))) + + let () = + fn "tree_clone" + (repo @-> tree @-> returning tree) + (fun (type repo) repo tr -> + with_repo' repo tree + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let tree : Store.tree = Root.get_tree (module Store) tr in + Root.create_tree (module Store) tree)) + + let () = + fn "tree_hash" + (repo @-> tree @-> returning hash) + (fun (type repo) repo tree -> + with_repo' repo hash + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let tree : Store.tree = Root.get_tree (module Store) tree in + let k = Store.Tree.hash tree in + Root.create_hash (module Store) k)) + + let () = + fn "tree_of_hash" + (repo @-> hash @-> returning tree) + (fun (type repo) repo k -> + with_repo' repo tree + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + let k = Root.get_hash (module Store) k in + let t = run (Store.Tree.of_hash repo (`Node k)) in + match t with + | Some t -> Root.create_tree (module Store) t + | None -> null tree)) + + let () = + fn "tree_key" + (repo @-> tree @-> returning kinded_key) + (fun (type repo) repo tree -> + with_repo' repo kinded_key + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let tree : Store.tree = Root.get_tree (module Store) tree in + let k = Store.Tree.key tree in + match k with + | Some k -> Root.create_kinded_key (module Store) k + | _ -> null kinded_key)) + + let () = + fn "tree_of_key" + (repo @-> kinded_key @-> returning tree) + (fun (type repo) repo k -> + with_repo' repo tree + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> + let k = Root.get_kinded_key (module Store) k in + let t = run (Store.Tree.of_key repo k) in + match t with + | Some t -> Root.create_tree (module Store) t + | None -> null tree)) + + let () = + fn "tree_mem" + (repo @-> tree @-> path @-> returning bool) + (fun (type repo) repo tree path -> + with_repo repo false + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let tree : Store.tree = Root.get_tree (module Store) tree in + let path : Store.path = Root.get_path (module Store) path in + run (Store.Tree.mem tree path))) + + let () = + fn "tree_mem_tree" + (repo @-> tree @-> path @-> returning bool) + (fun (type repo) repo tree path -> + with_repo repo false + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let tree : Store.tree = Root.get_tree (module Store) tree in + let path : Store.path = Root.get_path (module Store) path in + run (Store.Tree.mem_tree tree path))) + + let () = + fn "tree_find" + (repo @-> tree @-> path @-> returning contents) + (fun (type repo) repo tree path -> + with_repo' repo contents + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let tree : Store.tree = Root.get_tree (module Store) tree in + let path : Store.path = Root.get_path (module Store) path in + match run (Store.Tree.find tree path) with + | None -> null contents + | Some x -> Root.create_contents (module Store) x)) + + let () = + fn "tree_find_metadata" + (repo @-> tree @-> path @-> returning metadata) + (fun (type repo) repo tree path -> + with_repo' repo metadata + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let tree : Store.tree = Root.get_tree (module Store) tree in + let path : Store.path = Root.get_path (module Store) path in + match run (Store.Tree.find_all tree path) with + | None -> null metadata + | Some (_, m) -> Root.create_metadata (module Store) m)) + + let () = + fn "tree_find_tree" + (repo @-> tree @-> path @-> returning tree) + (fun (type repo) repo t path -> + with_repo' repo tree + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let t : Store.tree = Root.get_tree (module Store) t in + let path : Store.path = Root.get_path (module Store) path in + match run (Store.Tree.find_tree t path) with + | None -> null tree + | Some x -> Root.create_tree (module Store) x)) + + let () = + fn "tree_add" + (repo @-> tree @-> path @-> contents @-> metadata @-> returning bool) + (fun (type repo) repo tree path value metadata -> + with_repo repo false + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let tree' : Store.tree = Root.get_tree (module Store) tree in + let path : Store.path = Root.get_path (module Store) path in + let value : Store.contents = + Root.get_contents (module Store) value + in + let metadata = + if is_null metadata then None + else Some (Root.get_metadata (module Store) metadata) + in + let t = run (Store.Tree.add tree' path value ?metadata) in + Root.set_tree (module Store) tree t; + true)) + + let () = + fn "tree_add_tree" + (repo @-> tree @-> path @-> tree @-> returning bool) + (fun (type repo) repo tree path tr -> + with_repo repo false + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let tree' : Store.tree = Root.get_tree (module Store) tree in + let path : Store.path = Root.get_path (module Store) path in + let value : Store.tree = Root.get_tree (module Store) tr in + let t = run (Store.Tree.add_tree tree' path value) in + Root.set_tree (module Store) tree t; + true)) + + let () = + fn "tree_remove" + (repo @-> tree @-> path @-> returning bool) + (fun (type repo) repo tree path -> + with_repo repo false + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let tree' : Store.tree = Root.get_tree (module Store) tree in + let path : Store.path = Root.get_path (module Store) path in + let t = run (Store.Tree.remove tree' path) in + Root.set_tree (module Store) tree t; + true)) + + let () = + fn "tree_equal" + (repo @-> tree @-> tree @-> returning bool) + (fun (type repo) repo a b -> + with_repo repo false + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let a = Root.get_tree (module Store) a in + let b = Root.get_tree (module Store) b in + Irmin.Type.(unstage (equal Store.tree_t)) a b)) + + let () = + fn "tree_list" + (repo @-> tree @-> path @-> returning path_array) + (fun (type repo) repo tree path -> + with_repo' repo path_array + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let tree = Root.get_tree (module Store) tree in + let path : Store.path = Root.get_path (module Store) path in + let items = run (Store.Tree.list tree path) in + let items = List.map (fun (k, _v) -> Store.Path.v [ k ]) items in + Root.create_path_array (module Store) items)) + + let () = + fn "kinded_key_is_contents" + (repo @-> kinded_key @-> returning bool) + (fun (type repo) repo k -> + with_repo repo false + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let k = Root.get_kinded_key (module Store) k in + match k with `Contents _ -> true | _ -> false)) + + let () = + fn "kinded_key_is_node" + (repo @-> kinded_key @-> returning bool) + (fun (type repo) repo k -> + with_repo repo false + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + let k = Root.get_kinded_key (module Store) k in + match k with `Node _ -> true | _ -> false)) + + let () = fn "tree_free" (tree @-> returning void) free + let () = fn "kinded_key_free" (kinded_key @-> returning void) free +end diff --git a/vendors/irmin/src/libirmin/type.ml b/vendors/irmin/src/libirmin/type.ml new file mode 100644 index 0000000000000000000000000000000000000000..bf5247d21fa2a89c397c9be8f92be091d0134772 --- /dev/null +++ b/vendors/irmin/src/libirmin/type.ml @@ -0,0 +1,194 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Cstubs_inverted.INTERNAL) = struct + open Util.Make (I) + + let () = + fn "type_unit" + (void @-> returning ty) + (fun () -> Root.create_ty Irmin.Type.unit) + + let () = + fn "type_bool" + (void @-> returning ty) + (fun () -> Root.create_ty Irmin.Type.bool) + + let () = + fn "type_int" + (void @-> returning ty) + (fun () -> Root.create_ty Irmin.Type.int) + + let () = + fn "type_float" + (void @-> returning ty) + (fun () -> Root.create_ty Irmin.Type.float) + + let () = + fn "type_string" + (void @-> returning ty) + (fun () -> Root.create_ty Irmin.Type.string) + + let () = + fn "type_bytes" + (void @-> returning ty) + (fun () -> Root.create_ty Irmin.Type.bytes) + + let () = + fn "type_list" + (ty @-> returning ty) + (fun elem -> + let elem : 'a Irmin.Type.t = Root.get_ty elem in + Root.create_ty (Irmin.Type.list elem)) + + let () = + fn "type_array" + (ty @-> returning ty) + (fun elem -> + let elem : 'a Irmin.Type.t = Root.get_ty elem in + Root.create_ty (Irmin.Type.array elem)) + + let () = + fn "type_option" + (ty @-> returning ty) + (fun elem -> + let elem : 'a Irmin.Type.t = Root.get_ty elem in + Root.create_ty (Irmin.Type.option elem)) + + let () = + fn "type_json" + (void @-> returning ty) + (fun () -> Root.create_ty Irmin.Contents.Json.t) + + let () = + fn "type_json_value" + (void @-> returning ty) + (fun () -> Root.create_ty Irmin.Contents.Json_value.t) + + let () = + fn "type_path" + (repo @-> returning ty) + (fun (type repo) repo -> + with_repo' repo ty + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_ty Store.path_t)) + + let () = + fn "type_commit" + (repo @-> returning ty) + (fun (type repo) repo -> + with_repo' repo ty + (fun (module Store : Irmin.Generic_key.S with type repo = repo) repo + -> Root.create_ty (Store.commit_t repo))) + + let () = + fn "type_metadata" + (repo @-> returning ty) + (fun (type repo) repo -> + with_repo' repo ty + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_ty Store.metadata_t)) + + let () = + fn "type_tree" + (repo @-> returning ty) + (fun (type repo) repo -> + with_repo' repo ty + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_ty Store.tree_t)) + + let () = + fn "type_hash" + (repo @-> returning ty) + (fun (type repo) repo -> + with_repo' repo ty + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_ty Store.hash_t)) + + let () = + fn "type_commit_key" + (repo @-> returning ty) + (fun (type repo) repo -> + with_repo' repo ty + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_ty Store.commit_key_t)) + + let () = + fn "type_contents_key" + (repo @-> returning ty) + (fun (type repo) repo -> + with_repo' repo ty + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_ty Store.contents_key_t)) + + let () = + fn "type_node_key" + (repo @-> returning ty) + (fun (type repo) repo -> + with_repo' repo ty + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_ty Store.node_key_t)) + + let () = + fn "type_kinded_key" + (repo @-> returning ty) + (fun (type repo) repo -> + with_repo' repo ty + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_ty Store.Tree.kinded_key_t)) + + let () = + fn "type_contents" + (repo @-> returning ty) + (fun (type repo) repo -> + with_repo' repo ty + (fun (module Store : Irmin.Generic_key.S with type repo = repo) _ -> + Root.create_ty Store.contents_t)) + + let () = + fn "type_pair" + (ty @-> ty @-> returning ty) + (fun a b -> + let a : 'a Irmin.Type.t = Root.get_ty a in + let b : 'b Irmin.Type.t = Root.get_ty b in + Root.create_ty (Irmin.Type.pair a b)) + + let () = + fn "type_triple" + (ty @-> ty @-> ty @-> returning ty) + (fun a b c -> + let a : 'a Irmin.Type.t = Root.get_ty a in + let b : 'b Irmin.Type.t = Root.get_ty b in + let c : 'c Irmin.Type.t = Root.get_ty c in + Root.create_ty (Irmin.Type.triple a b c)) + + let () = + fn "type_name" + (ty @-> returning irmin_string) + (fun ty -> + let ty = Root.get_ty ty in + let s = Fmt.to_to_string Irmin.Type.pp_ty ty in + Root.create_string s) + + let () = + fn "type_diff" + (ty @-> returning ty) + (fun ty -> + let ty = Root.get_ty ty in + Root.create_ty (Irmin.Diff.t ty)) + + let () = fn "type_free" (ty @-> returning void) free +end diff --git a/vendors/irmin/src/libirmin/types.ml b/vendors/irmin/src/libirmin/types.ml new file mode 100644 index 0000000000000000000000000000000000000000..a82e7e372463f733c94e351deae2843e29610fb3 --- /dev/null +++ b/vendors/irmin/src/libirmin/types.ml @@ -0,0 +1,68 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Ctypes +include Types_intf + +module Struct = struct + type config = unit + type repo = unit + type store = unit + type ty = unit + type value = unit + type metadata = unit + type contents = unit + type path = unit + type tree = unit + type commit = unit + type hash = unit + type info = unit + type irmin_string = unit + type path_array = unit + type commit_array = unit + type branch_array = unit + type commit_key = unit + type kinded_key = unit + type remote = unit +end + +let config : Struct.config ptr typ = ptr (typedef void "IrminConfig") +let repo : Struct.repo ptr typ = ptr (typedef void "IrminRepo") +let store : Struct.store ptr typ = ptr (typedef void "Irmin") +let ty : Struct.ty ptr typ = ptr (typedef void "IrminType") +let value : Struct.value ptr typ = ptr (typedef void "IrminValue") +let metadata : Struct.metadata ptr typ = ptr (typedef void "IrminMetadata") +let contents : Struct.metadata ptr typ = ptr (typedef void "IrminContents") +let path : Struct.path ptr typ = ptr (typedef void "IrminPath") +let tree : Struct.tree ptr typ = ptr (typedef void "IrminTree") +let commit : Struct.commit ptr typ = ptr (typedef void "IrminCommit") +let hash : Struct.hash ptr typ = ptr (typedef void "IrminHash") +let info : Struct.info ptr typ = ptr (typedef void "IrminInfo") +let remote : Struct.remote ptr typ = ptr (typedef void "IrminRemote") + +let irmin_string : Struct.irmin_string ptr typ = + ptr (typedef void "IrminString") + +let path_array : Struct.path_array ptr typ = ptr (typedef void "IrminPathArray") + +let commit_array : Struct.commit_array ptr typ = + ptr (typedef void "IrminCommitArray") + +let branch_array : Struct.branch_array ptr typ = + ptr (typedef void "IrminBranchArray") + +let commit_key : Struct.commit_key ptr typ = ptr (typedef void "IrminCommitKey") +let kinded_key : Struct.kinded_key ptr typ = ptr (typedef void "IrminKindedKey") diff --git a/vendors/irmin/src/libirmin/types.mli b/vendors/irmin/src/libirmin/types.mli new file mode 100644 index 0000000000000000000000000000000000000000..eff19f25a5069f4fe508cc4d3c2e76d826c23893 --- /dev/null +++ b/vendors/irmin/src/libirmin/types.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Types_intf.Sigs diff --git a/vendors/irmin/src/libirmin/types_intf.ml b/vendors/irmin/src/libirmin/types_intf.ml new file mode 100644 index 0000000000000000000000000000000000000000..c3246efa284fbc798aa1af71fd2b04a830b0db3d --- /dev/null +++ b/vendors/irmin/src/libirmin/types_intf.ml @@ -0,0 +1,82 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Ctypes + +type config = Irmin_cli.Resolver.Store.t * Irmin.config + +type 'a repo = { + mutable error : string option; + repo_mod : (module Irmin.Generic_key.S with type repo = 'a); + repo : 'a; + remote : Irmin_cli.Resolver.Store.remote_fn option; +} + +type 'a store = { + repo : unit ptr; + store_mod : (module Irmin.Generic_key.S with type t = 'a); + store : 'a; +} + +module type P = sig + type config + type repo + type store + type ty + type value + type metadata + type contents + type path + type tree + type commit + type hash + type info + type irmin_string + type path_array + type commit_array + type branch_array + type commit_key + type kinded_key + type remote +end + +module type Sigs = sig + module Struct : P + + type nonrec config = config + type nonrec 'a repo = 'a repo + type nonrec 'a store = 'a store + + val config : Struct.config ptr typ + val repo : Struct.repo ptr typ + val store : Struct.store ptr typ + val ty : Struct.ty ptr typ + val value : Struct.value ptr typ + val metadata : Struct.metadata ptr typ + val contents : Struct.contents ptr typ + val path : Struct.path ptr typ + val tree : Struct.tree ptr typ + val commit : Struct.commit ptr typ + val hash : Struct.hash ptr typ + val info : Struct.info ptr typ + val irmin_string : Struct.irmin_string ptr typ + val path_array : Struct.path_array ptr typ + val commit_array : Struct.commit_array ptr typ + val branch_array : Struct.branch_array ptr typ + val commit_key : Struct.commit_key ptr typ + val kinded_key : Struct.kinded_key ptr typ + val remote : Struct.remote ptr typ +end diff --git a/vendors/irmin/src/libirmin/util.ml b/vendors/irmin/src/libirmin/util.ml new file mode 100644 index 0000000000000000000000000000000000000000..27ed6a6c4dd62f35171427345c12db922796871d --- /dev/null +++ b/vendors/irmin/src/libirmin/util.ml @@ -0,0 +1,286 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Cstubs_inverted.INTERNAL) = struct + include Ctypes + include Types + include Unsigned + + let find_config_key config name = + Irmin.Backend.Conf.Spec.find_key (Irmin.Backend.Conf.spec config) name + + let type_name x = Fmt.to_to_string Irmin.Type.pp_ty x + + (* Generic free function for all rooted values *) + let free x = + let ptr = Ctypes.to_voidp x in + if not (is_null ptr) then (fun x -> Ctypes.Root.release x) ptr + + let strlen ptr = + if is_null ptr then 0 + else + let rec loop i = + if !@(ptr +@ i) = char_of_int 0 then i else loop (i + 1) + in + loop 0 + + let get_length length s = + let length = Int64.to_int length in + if length < 0 then strlen s else length + + let fn name t f = I.internal ~runtime_lock:false ("irmin_" ^ name) t f + + (* Minimal executor for lwt promises *) + let rec run x = + Lwt.wakeup_paused (); + match Lwt.poll x with + | Some x -> x + | None -> + let () = Lwt_engine.iter true in + run x + + module Root = struct + let to_voidp t x = Ctypes.coerce t (ptr void) x + + let of_voidp t x = + if is_null x then failwith "null pointer" + else Ctypes.coerce (ptr void) t x + + let get_repo (type a) (x : Struct.repo ptr) : a repo = + Root.get (to_voidp repo x) + [@@inline] + + let create_repo (type a) (module S : Irmin.Generic_key.S with type repo = a) + (r : a repo) : Struct.repo ptr = + Root.create r |> of_voidp repo + [@@inline] + + let get_store (type a) (x : Struct.store ptr) : a store = + Root.get (to_voidp store x) + [@@inline] + + let create_store (type a) (module S : Irmin.Generic_key.S with type t = a) + (r : a store) : Struct.store ptr = + Root.create r |> of_voidp store + [@@inline] + + let get_config (x : Struct.config ptr) : config = + Root.get (to_voidp config x) + + let create_config (r : config) : Struct.config ptr = + Root.create r |> of_voidp config + + let set_config (ptr : Struct.config ptr) (x : config) = + Root.set (to_voidp config ptr) x + + let get_ty (x : Struct.ty ptr) : 'a Irmin.Type.t = Root.get (to_voidp ty x) + + let create_ty (x : 'a Irmin.Type.t) : Struct.ty ptr = + Root.create x |> of_voidp ty + + let get_value (x : Struct.value ptr) : 'a = Root.get (to_voidp value x) + let set_value (ptr : Struct.value ptr) x = Root.set (to_voidp value ptr) x + + let create_value (x : 'a) : Struct.value ptr = + Root.create x |> of_voidp value + + let get_path (type a) + (module S : Irmin.Generic_key.S with type Schema.Path.t = a) + (x : Struct.path ptr) : S.path = + Root.get (to_voidp path x) + + let create_path (type a) + (module S : Irmin.Generic_key.S with type Schema.Path.t = a) + (r : S.path) : Struct.path ptr = + Root.create r |> of_voidp path + + let get_metadata (type a) + (module S : Irmin.Generic_key.S with type Schema.Metadata.t = a) + (x : Struct.metadata ptr) : S.metadata = + Root.get (to_voidp metadata x) + + let create_metadata (type a) + (module S : Irmin.Generic_key.S with type Schema.Metadata.t = a) + (r : S.metadata) : Struct.metadata ptr = + Root.create r |> of_voidp metadata + + let get_hash (type a) + (module S : Irmin.Generic_key.S with type Schema.Hash.t = a) + (x : Struct.hash ptr) : S.hash = + Root.get (to_voidp hash x) + + let create_hash (type a) + (module S : Irmin.Generic_key.S with type Schema.Hash.t = a) + (r : S.hash) : Struct.hash ptr = + Root.create r |> of_voidp hash + + let get_commit_key (type a) + (module S : Irmin.Generic_key.S with type commit_key = a) + (x : Struct.commit_key ptr) : S.commit_key = + Root.get (to_voidp commit_key x) + + let create_commit_key (type a) + (module S : Irmin.Generic_key.S with type commit_key = a) + (r : S.commit_key) : Struct.commit_key ptr = + Root.create r |> of_voidp commit_key + + let get_kinded_key (type a b c) + (module S : Irmin.Generic_key.S + with type node_key = a + and type contents_key = b + and type Schema.Metadata.t = c) (x : Struct.kinded_key ptr) : + S.Tree.kinded_key = + Root.get (to_voidp kinded_key x) + + let create_kinded_key (type a b c) + (module S : Irmin.Generic_key.S + with type node_key = a + and type contents_key = b + and type Schema.Metadata.t = c) (r : S.Tree.kinded_key) : + Struct.kinded_key ptr = + Root.create r |> of_voidp kinded_key + + let get_tree (type a) (module S : Irmin.Generic_key.S with type tree = a) + (x : Struct.tree ptr) : S.tree = + Root.get (to_voidp tree x) + + let create_tree (type a) (module S : Irmin.Generic_key.S with type tree = a) + (r : S.tree) : Struct.tree ptr = + Root.create r |> of_voidp tree + + let set_tree (type a) (module S : Irmin.Generic_key.S with type tree = a) + (ptr : Struct.tree ptr) (r : S.tree) = + Root.set (to_voidp tree ptr) r + + let get_commit (type a) + (module S : Irmin.Generic_key.S with type commit = a) + (x : Struct.commit ptr) : S.commit = + Root.get (to_voidp commit x) + + let create_commit (type a) + (module S : Irmin.Generic_key.S with type commit = a) (r : S.commit) : + Struct.commit ptr = + Root.create r |> of_voidp commit + + let get_contents (type a) + (module S : Irmin.Generic_key.S with type Schema.Contents.t = a) + (x : Struct.contents ptr) : S.contents = + Root.get (to_voidp contents x) + + let create_contents (type a) + (module S : Irmin.Generic_key.S with type Schema.Contents.t = a) + (r : S.contents) : Struct.contents ptr = + Root.create r |> of_voidp contents + + let get_info (type a) + (module S : Irmin.Generic_key.S with type Schema.Info.t = a) + (x : Struct.info ptr) : S.info = + Root.get (to_voidp info x) + + let set_info (type a) + (module S : Irmin.Generic_key.S with type Schema.Info.t = a) + (ptr : Struct.info ptr) (x : S.info) : unit = + Root.set (to_voidp info ptr) x + + let create_info (type a) + (module S : Irmin.Generic_key.S with type Schema.Info.t = a) + (r : S.info) : Struct.info ptr = + Root.create r |> of_voidp info + + let get_string (x : Struct.irmin_string ptr) : string = + Root.get (to_voidp irmin_string x) + + let set_string (ptr : Struct.irmin_string ptr) (x : string) : unit = + Root.set (to_voidp irmin_string ptr) x + + let create_string (s : string) : Struct.irmin_string ptr = + Root.create s |> of_voidp irmin_string + + let get_branch_array (type a) + (module S : Irmin.Generic_key.S with type Schema.Branch.t = a) + (x : Struct.branch_array ptr) : a array = + Root.get (to_voidp branch_array x) + + let create_branch_array (type a) + (module S : Irmin.Generic_key.S with type Schema.Branch.t = a) + (x : S.Branch.t list) : Struct.branch_array ptr = + Root.create (Array.of_list x) |> of_voidp branch_array + + let get_path_array (type a) + (module S : Irmin.Generic_key.S with type Schema.Path.t = a) + (x : Struct.path_array ptr) : a array = + Root.get (to_voidp path_array x) + + let create_path_array (type a) + (module S : Irmin.Generic_key.S with type Schema.Path.t = a) + (x : S.Path.t list) : Struct.path_array ptr = + Root.create (Array.of_list x) |> of_voidp path_array + + let get_commit_array (type a) + (module S : Irmin.Generic_key.S with type commit = a) + (x : Struct.commit_array ptr) : a array = + Root.get (to_voidp commit_array x) + + let create_commit_array (type a) + (module S : Irmin.Generic_key.S with type commit = a) (x : a list) : + Struct.commit_array ptr = + Root.create (Array.of_list x) |> of_voidp commit_array + + let get_remote (x : Struct.remote ptr) : Irmin.remote = + Root.get (to_voidp remote x) + + let create_remote (x : Irmin.remote) : Struct.remote ptr = + Root.create x |> of_voidp remote + end + + (* Handle errors and set error function, returns [return] if an exception is raised *) + let with_repo (repo : Struct.repo ptr) return f = + let repo = Root.get_repo repo in + try + repo.error <- None; + f repo.repo_mod repo.repo + with + | Failure msg | Invalid_argument msg -> + repo.error <- Some msg; + return + | exn -> + repo.error <- Some (Printexc.to_string exn); + return + [@@inline] + + let null t = Ctypes.coerce (ptr void) t null + + (* Similar to [with_repo] but returns a null pointer *) + let with_repo' (repo : Struct.repo ptr) t f = with_repo repo (null t) f + + let with_store (store : Struct.store ptr) return f = + let store = Root.get_store store in + let ctx = Root.get_repo (Root.of_voidp repo store.repo) in + try + ctx.error <- None; + f store.store_mod store.store + with + | Failure msg | Invalid_argument msg -> + ctx.error <- Some msg; + return + | exn -> + ctx.error <- Some (Printexc.to_string exn); + return + [@@inline] + + (* Similar to [with_store] but returns a null pointer *) + let with_store' (store : Struct.store ptr) t f = with_store store (null t) f +end diff --git a/vendors/irmin/src/libirmin/value.ml b/vendors/irmin/src/libirmin/value.ml new file mode 100644 index 0000000000000000000000000000000000000000..eafdc8e8ff22e835ef3f84ec088777e5de8869cd --- /dev/null +++ b/vendors/irmin/src/libirmin/value.ml @@ -0,0 +1,250 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (I : Cstubs_inverted.INTERNAL) = struct + open Util.Make (I) + + let () = + fn "value_unit" (void @-> returning value) (fun () -> Root.create_value ()) + + let () = + fn "value_int" + (int64_t @-> returning value) + (fun i -> Root.create_value (Int64.to_int i)) + + let () = + fn "value_float" (double @-> returning value) (fun i -> Root.create_value i) + + let () = + fn "value_bool" (bool @-> returning value) (fun b -> Root.create_value b) + + let () = + fn "value_clone" + (value @-> returning value) + (fun x -> Root.create_value (Root.get_value x)) + + let () = + fn "realloc" + (ptr void @-> ptr void @-> returning (ptr void)) + (fun src dest -> + Ctypes.Root.set src (Ctypes.Root.get dest); + src) + + let () = + fn "value_get_string" + (value @-> returning irmin_string) + (fun value -> + let obj = Root.get_value value |> Obj.repr in + if Obj.tag obj = Obj.string_tag then Root.create_string (Obj.obj obj) + else null irmin_string) + + let () = + fn "value_get_int" + (value @-> returning int64_t) + (fun x -> + let obj = Root.get_value x |> Obj.repr in + if Obj.is_int obj then Int64.of_int (Obj.obj obj) else Int64.zero) + + let () = + fn "value_get_bool" + (value @-> returning bool) + (fun x -> + let obj = Root.get_value x |> Obj.repr in + if Obj.is_int obj then Obj.obj obj else false) + + let () = + fn "value_get_float" + (value @-> returning double) + (fun x -> + let obj = Root.get_value x |> Obj.repr in + if Obj.is_int obj then Obj.obj obj else 0.) + + let () = + fn "value_bytes" + (ptr char @-> int64_t @-> returning value) + (fun s length -> + let length = get_length length s in + Root.create_value (Bytes.of_string (string_from_ptr s ~length))) + + let () = + fn "value_string" + (ptr char @-> int64_t @-> returning value) + (fun s length -> + let length = get_length length s in + Root.create_value (string_from_ptr s ~length)) + + let () = + fn "value_array" + (ptr value @-> uint64_t @-> returning value) + (fun arr n -> + let n = UInt64.to_int n in + let a = + if is_null arr || n = 0 then [||] + else + CArray.from_ptr arr n + |> CArray.to_list + |> List.map Root.get_value + |> Array.of_list + in + Root.create_value a) + + let () = + fn "value_list" + (ptr value @-> uint64_t @-> returning value) + (fun arr n -> + let n = UInt64.to_int n in + let l = + if is_null arr || n = 0 then [] + else + CArray.from_ptr arr n |> CArray.to_list |> List.map Root.get_value + in + Root.create_value l) + + let () = + fn "value_option" + (value @-> returning value) + (fun value -> + if is_null value then Root.create_value None + else + let x = Root.get_value value in + Root.create_value (Some x)) + + let () = + fn "value_pair" + (value @-> value @-> returning value) + (fun a b -> + let a = Root.get_value a in + let b = Root.get_value b in + Root.create_value (a, b)) + + let () = + fn "value_triple" + (value @-> value @-> value @-> returning value) + (fun a b c -> + let a = Root.get_value a in + let b = Root.get_value b in + let c = Root.get_value c in + Root.create_value (a, b, c)) + + let () = + fn "value_to_string" + (ty @-> value @-> returning irmin_string) + (fun ty value -> + let t = Root.get_ty ty in + let v = Root.get_value value in + let s = Irmin.Type.to_string t v in + Root.create_string s) + + let () = + fn "value_of_string" + (ty @-> ptr char @-> int64_t @-> returning value) + (fun ty s length -> + let length = get_length length s in + let ty = Root.get_ty ty in + let s = string_from_ptr s ~length in + match Irmin.Type.(of_string ty) s with + | Ok x -> Root.create_value x + | Error (`Msg _) -> null value) + + let () = + fn "value_to_bin" + (ty @-> value @-> returning irmin_string) + (fun ty v -> + let t = Root.get_ty ty in + let v = Root.get_value v in + let s = Irmin.Type.(unstage (to_bin_string t)) v in + Root.create_string s) + + let () = + fn "value_of_bin" + (ty @-> ptr char @-> int64_t @-> returning value) + (fun ty s length -> + let length = get_length length s in + let ty = Root.get_ty ty in + let s = string_from_ptr s ~length in + match Irmin.Type.(unstage (of_bin_string ty)) s with + | Ok x -> Root.create_value x + | Error (`Msg _) -> null value) + + let () = + fn "value_to_json" + (ty @-> value @-> returning irmin_string) + (fun ty v -> + let t = Root.get_ty ty in + let v = Root.get_value v in + let s = Irmin.Type.(to_json_string t) v in + Root.create_string s) + + let () = + fn "value_of_json" + (ty @-> ptr char @-> int64_t @-> returning value) + (fun ty s length -> + let length = get_length length s in + let ty = Root.get_ty ty in + let s = string_from_ptr s ~length in + match Irmin.Type.(of_json_string ty) s with + | Ok x -> Root.create_value x + | Error (`Msg _) -> null value) + + let () = + fn "value_equal" + (ty @-> value @-> value @-> returning bool) + (fun ty a b -> + let ty = Root.get_ty ty in + let a = Root.get_value a in + let b = Root.get_value b in + Irmin.Type.(unstage (equal ty)) a b) + + let () = + fn "value_compare" + (ty @-> value @-> value @-> returning int) + (fun ty a b -> + let ty = Root.get_ty ty in + let a = Root.get_value a in + let b = Root.get_value b in + Irmin.Type.(unstage (compare ty)) a b) + + let () = fn "value_free" (value @-> returning void) free + + let () = + fn "string_new" + (ptr char @-> int64_t @-> returning irmin_string) + (fun ptr i -> + let i = Int64.to_int i in + let length = if i < 0 then strlen ptr else i in + let s = string_from_ptr ptr ~length in + Root.create_string s) + + let () = + fn "string_data" + (irmin_string @-> returning (ptr char)) + (fun s -> + if is_null s then null (ptr char) + else + let s : string = Root.get_string s in + coerce string (ptr char) s) + + let () = + fn "string_length" + (irmin_string @-> returning uint64_t) + (fun s -> + if is_null s then UInt64.zero + else + let s : string = Root.get_string s in + String.length s |> UInt64.of_int) + + let () = fn "string_free" (irmin_string @-> returning void) free +end diff --git a/vendors/irmin/src/ppx_irmin/dune b/vendors/irmin/src/ppx_irmin/dune new file mode 100644 index 0000000000000000000000000000000000000000..5fda5ca9c60faca19a15b3dd8b4d87297d333ee8 --- /dev/null +++ b/vendors/irmin/src/ppx_irmin/dune @@ -0,0 +1,9 @@ +;; The publicly-available PPX for consumers of the Irmin API + +(library + (public_name ppx_irmin) + (modules ppx_irmin) + (kind ppx_deriver) + (libraries ppx_repr.lib) + (instrumentation + (backend bisect_ppx))) diff --git a/vendors/irmin/src/ppx_irmin/internal/dune b/vendors/irmin/src/ppx_irmin/internal/dune new file mode 100644 index 0000000000000000000000000000000000000000..b0fbd3c29a6fa9e2df92b017f7cfd34c2a63ccbe --- /dev/null +++ b/vendors/irmin/src/ppx_irmin/internal/dune @@ -0,0 +1,21 @@ +;; Extensions to `ppx_irmin` intended for Irmin developers only + +(library + (kind ppx_rewriter) + (name ppx_irmin_internal) + (public_name ppx_irmin.internal) + (modules ppx_irmin_internal) + (ppx_runtime_libraries logs ppx_irmin.internal-lib) + (preprocess + (pps ppxlib.metaquot)) + (libraries + ppxlib + ppx_irmin.internal-lib + ;; Depending on [ppx_irmin.internal] implies a dependency on [ppx_irmin] + ppx_irmin)) + +(library + (name ppx_irmin_internal_lib) + (public_name ppx_irmin.internal-lib) + (modules ppx_irmin_internal_lib) + (libraries logs)) diff --git a/vendors/irmin/src/ppx_irmin/internal/ppx_irmin_internal.ml b/vendors/irmin/src/ppx_irmin/internal/ppx_irmin_internal.ml new file mode 100644 index 0000000000000000000000000000000000000000..67bddf5b2d2dd0bb100dbc37b8dd6bd8fa8c3fd8 --- /dev/null +++ b/vendors/irmin/src/ppx_irmin/internal/ppx_irmin_internal.ml @@ -0,0 +1,103 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Ppxlib + +let rewriter_name = "ppx_irmin.internal" + +(* Provides a PPX wrapper around the Logs library that attaches source code + postitions to log lines via Logs' tags system. + + Input: [%log(s?). ] + Output: Log(s?).() (fun f -> f ~tags:(...)) + + (The extension node payload can also be written in the standard CPSed form, + for instance in order to perform computation before constructing the log + line.) +*) + +module Source = struct + type t = + | Logs (** default (source-less) logging functions *) + | Log (** referencing a "Log" module, specifying a particular source *) + + let to_string = function Logs -> "logs" | Log -> "log" +end + +let level_to_function_name : Logs.level -> string = function + | App -> "app" + | Error -> "err" + | Warning -> "warn" + | Info -> "info" + | Debug -> "debug" + +let log_function ~loc (source : Source.t) (level : Logs.level) = + let prefix = match source with Logs -> "Logs." | Log -> "Log." in + Ast_builder.Default.evar ~loc (prefix ^ level_to_function_name level) + +let tags ~loc = + [%expr + Logs.Tag.add Ppx_irmin_internal_lib.Source_code_position.tag __POS__ + Logs.Tag.empty] + +let expansion_function source level ~loc ~path:_ payload = + let log_fn = log_function ~loc source level in + let open Ast_builder.Default in + match payload with + | [%expr fun [%p? _] -> [%e? _]] -> + (* Payload is already in CPS-ed form: we just need to attach the tags. *) + [%expr + [%e log_fn] (fun f -> + ([%e payload] : (?header:string -> (_, _, _, _) format4 -> _) -> _) + (f ~tags:[%e tags ~loc]))] + | _ -> + (* The user hasn't wrapped the payload in [fun f -> ...; f ...], so we + should attempt to do so. This requires re-interpreting top-level + [Pexp_apply] nodes in the AST, for example: + + > [%log.debug "fmt_string" ...args] + + This parses ["fmt_string"] as a _function_, but it's going to become + the first argument of a function [debug]. *) + let input_args = + match payload with + | { pexp_desc = Pexp_constant (Pconst_string _); _ } -> + [ (Nolabel, payload) ] + (* Special case for ( @@ ), e.g. [%log.err "%d" @@ 1 + 2] *) + | [%expr [%e? fmt] @@ [%e? args]] -> [ (Nolabel, fmt); (Nolabel, args) ] + | { pexp_desc = Pexp_apply (fmt, args); _ } -> (Nolabel, fmt) :: args + | _ -> Location.raise_errorf ~loc "%s: invalid payload" rewriter_name + in + let args = input_args @ [ (Labelled "tags", tags ~loc) ] in + [%expr [%e log_fn] (fun f -> [%e pexp_apply ~loc [%expr f] args])] + +let ( let* ) x f = List.concat_map f x + +let rules = + let* source = [ Source.Logs; Log ] in + let* level = [ Logs.App; Error; Warning; Info; Debug ] in + let extension_name = + Format.sprintf "irmin.%s.%s" (Source.to_string source) + (level_to_function_name level) + in + [ + Extension.declare extension_name Extension.Context.expression + Ast_pattern.(single_expr_payload __) + (expansion_function source level) + |> Context_free.Rule.extension; + ] + +let () = Driver.register_transformation ~rules rewriter_name diff --git a/vendors/irmin/src/ppx_irmin/internal/ppx_irmin_internal.mli b/vendors/irmin/src/ppx_irmin/internal/ppx_irmin_internal.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/src/ppx_irmin/internal/ppx_irmin_internal.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/src/ppx_irmin/internal/ppx_irmin_internal_lib.ml b/vendors/irmin/src/ppx_irmin/internal/ppx_irmin_internal_lib.ml new file mode 100644 index 0000000000000000000000000000000000000000..73be6aa171b358cbaf8a90d9c23da59282383e0e --- /dev/null +++ b/vendors/irmin/src/ppx_irmin/internal/ppx_irmin_internal_lib.ml @@ -0,0 +1,30 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Source_code_position = struct + type t = string * int * int * int + (** The type of inclusive ranges of source code positions, as generated by the + OCaml {!__POS__} macro. The 4-tuple components are 'file name', 'line + number', 'column start' and 'column end' respectively. *) + + let pp ppf (fname, line_number, col_start, col_end) = + Format.fprintf ppf "File %S, line %d, characters %d-%d" fname line_number + col_start col_end + + let tag : t Logs.Tag.def = + Logs.Tag.def "Source_code_position" + ~doc:"The source code location at which the log entry was generated." pp +end diff --git a/vendors/irmin/src/ppx_irmin/ppx_irmin.ml b/vendors/irmin/src/ppx_irmin/ppx_irmin.ml new file mode 100644 index 0000000000000000000000000000000000000000..dfc757c35ab78cc067777e49b659536bb5af304c --- /dev/null +++ b/vendors/irmin/src/ppx_irmin/ppx_irmin.ml @@ -0,0 +1,25 @@ +(* + * Copyright (c) 2019-2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Plugins = Ppx_repr_lib.Plugins.Make (struct + let default_library = "Irmin.Type" + let namespace = "irmin" +end) + +let () = + Plugins.register_deriver (); + Plugins.register_extension ~no_reserve_namespace:() () diff --git a/vendors/irmin/src/ppx_irmin/ppx_irmin.mli b/vendors/irmin/src/ppx_irmin/ppx_irmin.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/src/ppx_irmin/ppx_irmin.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin-bench/data/tezos_actions_1commit.repr b/vendors/irmin/test/irmin-bench/data/tezos_actions_1commit.repr new file mode 100644 index 0000000000000000000000000000000000000000..8dc02daeb592fe9d641b4c2450d217db7bac401d Binary files /dev/null and b/vendors/irmin/test/irmin-bench/data/tezos_actions_1commit.repr differ diff --git a/vendors/irmin/test/irmin-bench/dune b/vendors/irmin/test/irmin-bench/dune new file mode 100644 index 0000000000000000000000000000000000000000..3eed2ce65712037d633fee0060411a455403d000 --- /dev/null +++ b/vendors/irmin/test/irmin-bench/dune @@ -0,0 +1,11 @@ +(executable + (name test) + (libraries alcotest irmin_traces fpath irmin-tezos irmin-pack.mem) + (preprocess + (pps ppx_irmin.internal))) + +(rule + (alias runtest) + (package irmin-bench) + (action + (run ./test.exe -q --color=always))) diff --git a/vendors/irmin/test/irmin-bench/ema.ml b/vendors/irmin/test/irmin-bench/ema.ml new file mode 100644 index 0000000000000000000000000000000000000000..b0c5519b755a47bd79196114b004694dd4e5e137 --- /dev/null +++ b/vendors/irmin/test/irmin-bench/ema.ml @@ -0,0 +1,179 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module Ema = Irmin_traces.Trace_stat_summary_utils.Exponential_moving_average + +(* Section 1/2 - Tools *) + +let pp_ema ppf ema = + let open Ema in + Format.fprintf ppf "peek:%g; hs:%g; vf:%g" (peek_or_nan ema) + (hidden_state ema) (void_fraction ema) + +let feed ~n v ema = + assert (n >= 0); + let rec aux ema = function 0 -> ema | i -> aux (Ema.update ema v) (i - 1) in + aux ema n + +let feed_none ~n ema = + assert (n >= 0); + let rec aux ema = function 0 -> ema | i -> aux (Ema.forget ema) (i - 1) in + aux ema n + +(* Section 2/2 - Tests *) + +let test_momentum () = + let ema = Ema.create 0.5 in + let ema = feed ~n:9999 1000. ema in + Alcotest.(check (float 1e-100)) "Ema primed" (Ema.void_fraction ema) 0.; + let ema = feed ~n:1 0. ema in + Alcotest.(check (float 0.1)) "1st half life" (Ema.peek_exn ema) 500.; + let ema = feed ~n:1 0. ema in + Alcotest.(check (float 0.1)) "2nd half life" (Ema.peek_exn ema) 250.; + let ema = feed ~n:1 0. ema in + Alcotest.(check (float 0.1)) "3rd half life" (Ema.peek_exn ema) 125. + +let test_momentum_zero () = + let ema = Ema.create 0. in + let ema = feed ~n:1 500. ema in + Alcotest.(check (float 0.1)) "1st value" (Ema.peek_exn ema) 500.; + let ema = feed ~n:1 250. ema in + Alcotest.(check (float 0.1)) "2nd value" (Ema.peek_exn ema) 250.; + let ema = feed ~n:1 125. ema in + Alcotest.(check (float 0.1)) "3rd value" (Ema.peek_exn ema) 125. + +let test_momentum_high () = + let ema = Ema.create 0.9999999 in + let ema = feed ~n:1 500. ema in + Alcotest.(check (float 0.1)) "1st mean" (Ema.peek_exn ema) 500.; + let ema = feed ~n:1 300. ema in + Alcotest.(check (float 0.1)) + "2nd mean" (Ema.peek_exn ema) + ((500. +. 300.) /. 2.); + let ema = feed ~n:1 100. ema in + Alcotest.(check (float 0.1)) + "3rd mean" (Ema.peek_exn ema) + ((500. +. 300. +. 100.) /. 3.); + + let ema = feed ~n:10000 1000. ema in + Alcotest.(check (float 10.)) "4th mean" (Ema.peek_exn ema) 1000.; + let ema = feed ~n:10000 2000. ema in + Alcotest.(check (float 10.)) "5th mean" (Ema.peek_exn ema) 1500. + +let test_from_half_life () = + let ema = Ema.from_half_life 10. in + let ema = feed ~n:9999 1000. ema in + Alcotest.(check (float 1e-100)) "Ema primed" (Ema.void_fraction ema) 0.; + let ema = feed ~n:10 0. ema in + Alcotest.(check (float 0.1)) "1st half life" (Ema.peek_exn ema) 500.; + let ema = feed ~n:10 0. ema in + Alcotest.(check (float 0.1)) "2nd half life" (Ema.peek_exn ema) 250.; + let ema = feed ~n:10 0. ema in + Alcotest.(check (float 0.1)) "3rd half life" (Ema.peek_exn ema) 125. + +let test_from_half_life_ratio () = + let ema = Ema.from_half_life_ratio 0.1 100. in + let ema = feed ~n:9999 1000. ema in + Alcotest.(check (float 1e-100)) "Ema primed" (Ema.void_fraction ema) 0.; + let ema = feed ~n:10 0. ema in + Alcotest.(check (float 0.1)) "1st half life" (Ema.peek_exn ema) 500.; + let ema = feed ~n:10 0. ema in + Alcotest.(check (float 0.1)) "2nd half life" (Ema.peek_exn ema) 250.; + let ema = feed ~n:10 0. ema in + Alcotest.(check (float 0.1)) "3rd half life" (Ema.peek_exn ema) 125. + +let test_update_batch () = + let ema0 = Ema.create 0.5 |> feed ~n:10 42. in + let ema1 = feed ~n:5 21. ema0 in + let ema1' = Ema.update_batch ema0 21. 5. in + Alcotest.(check (float 0.0001)) + "2way batch" (Ema.peek_exn ema1) (Ema.peek_exn ema1') + +let test_relevance () = + let ema = Ema.create ~relevance_threshold:0.51 0.5 in + Alcotest.(check bool) "Ema empty" (Ema.is_relevant ema) false; + let ema = feed ~n:1 42. ema in + Alcotest.(check bool) "1U" (Ema.is_relevant ema) true; + let ema = feed_none ~n:1 ema in + Alcotest.(check bool) "1U, 1F" (Ema.is_relevant ema) false; + let ema = feed ~n:1 42. ema in + Alcotest.(check bool) "1U, 1F, 1U" (Ema.is_relevant ema) true; + let ema = feed ~n:99 42. ema |> feed_none ~n:1 in + Alcotest.(check bool) "1U, 1F, 100U, 1F" (Ema.is_relevant ema) true; + let ema = feed_none ~n:1 ema in + Alcotest.(check bool) "1U, 1F, 100U, 2F" (Ema.is_relevant ema) false + +let test_relevance_low () = + let ema = Ema.create ~relevance_threshold:0.01 0.5 in + Alcotest.(check bool) "Ema empty" (Ema.is_relevant ema) false; + let ema = feed ~n:5 42. ema in + Alcotest.(check bool) "5U" (Ema.is_relevant ema) false; + let ema = feed ~n:10 42. ema in + Alcotest.(check bool) "10U" (Ema.is_relevant ema) true; + let ema = feed_none ~n:1 ema in + Alcotest.(check bool) "10U, 1F" (Ema.is_relevant ema) false + +let test_relevance_one () = + let ema = Ema.create ~relevance_threshold:1.0 0.5 in + Alcotest.(check bool) "Ema empty" (Ema.is_relevant ema) false; + let ema = feed ~n:1 42. ema in + Alcotest.(check bool) "1U" (Ema.is_relevant ema) true; + let ema = feed_none ~n:10 ema in + Alcotest.(check bool) "1U, 10F" (Ema.is_relevant ema) true + +let test_commutativity_shift () = + let add a b = List.map2 ( +. ) a b in + let mom = 0.1 in + let xs = [ 10.0; -5.0; 6.0; -7.0; -20.0; 5.0; 9.0 ] in + let ys = [ 7.0; 3.0; -6.0; -1.0; -3.0; 4.0; 7.0 ] in + let res = Ema.map mom (add xs ys) in + let res' = add (Ema.map mom xs) (Ema.map mom ys) in + Alcotest.(check (list (float 0.0001))) "ema(a + b) = ema(a) + ema(b)" res res' + +let test_commutativity_log_mul () = + let mul a b = List.map2 ( *. ) a b in + let log l = List.map Float.log l in + let exp l = List.map Float.exp l in + let mom = 0.1 in + let xs = [ 10.0; 5.0; 6.0; 7.0; 20.0; 5.0; 9.0 ] in + let ys = [ 7.0; 3.0; 6.0; 1.0; 3.0; 4.0; 7.0 ] in + let res = mul xs ys |> log |> Ema.map mom |> exp in + let res' = + mul (xs |> log |> Ema.map mom |> exp) (ys |> log |> Ema.map mom |> exp) + in + Alcotest.(check (list (float 0.0001))) + "exp(ema(log(a))) * exp(ema(log(b))) = exp(ema(log(a * b)))" res res' + +let test_cases = + [ + ( "ema", + [ + Alcotest.test_case "momentum" `Quick test_momentum; + Alcotest.test_case "momentum_zero" `Quick test_momentum_zero; + Alcotest.test_case "momentum_high" `Quick test_momentum_high; + Alcotest.test_case "from_half_life" `Quick test_from_half_life; + Alcotest.test_case "from_half_life_ratio" `Quick + test_from_half_life_ratio; + Alcotest.test_case "batch" `Quick test_update_batch; + Alcotest.test_case "relevance" `Quick test_relevance; + Alcotest.test_case "relevance_low" `Quick test_relevance_low; + Alcotest.test_case "relevance_one" `Quick test_relevance_one; + Alcotest.test_case "commutativity shift" `Quick test_commutativity_shift; + Alcotest.test_case "commutativity logmul" `Quick + test_commutativity_log_mul; + ] ); + ] diff --git a/vendors/irmin/test/irmin-bench/import.ml b/vendors/irmin/test/irmin-bench/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..2fed488f984d94afe2952e6353640928e3e5d132 --- /dev/null +++ b/vendors/irmin/test/irmin-bench/import.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/test/irmin-bench/misc.ml b/vendors/irmin/test/irmin-bench/misc.ml new file mode 100644 index 0000000000000000000000000000000000000000..34fdc04b4e4862db4b58c87b97bfb180696f1432 --- /dev/null +++ b/vendors/irmin/test/irmin-bench/misc.ml @@ -0,0 +1,86 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +let snap_around_42 () = + let f ~sd = + Irmin_traces.Trace_stat_summary_utils.snap_to_integer ~significant_digits:sd + in + Alcotest.(check (float 0.)) "Already integer" (f ~sd:0 42.) 42.; + Alcotest.(check (float 0.)) "Always snap" (f ~sd:0 42.1) 42.; + Alcotest.(check (float 0.)) "Always snap" (f ~sd:0 42.4999999999) 42.; + Alcotest.(check (float 0.)) "Always snap" (f ~sd:0 42.5000000001) 43.; + + Alcotest.(check (float 0.)) "No snap" (f ~sd:4 42.1) 42.1; + Alcotest.(check (float 0.)) "No snap" (f ~sd:4 42.01) 42.01; + Alcotest.(check (float 0.)) "No snap" (f ~sd:4 42.00110000) 42.00110000; + Alcotest.(check (float 0.)) "No snap" (f ~sd:4 42.00100000) 42.00100000; + Alcotest.(check (float 0.)) "No snap" (f ~sd:4 42.00099999) 42.00099999; + Alcotest.(check (float 0.)) "No snap" (f ~sd:4 42.00011000) 42.00011000; + + Alcotest.(check (float 0.)) "Snap" (f ~sd:4 42.00009999) 42.; + Alcotest.(check (float 0.)) "Snap" (f ~sd:4 42.00001100) 42.; + Alcotest.(check (float 0.)) "Snap" (f ~sd:4 42.00001000) 42.; + Alcotest.(check (float 0.)) "Snap" (f ~sd:4 42.00000999) 42.; + Alcotest.(check (float 0.)) "Already integer" (f ~sd:4 42.) 42. + +let test_transaction_count () = + let f = + Irmin_traces.Trace_stat_summary_utils + .approx_transaction_count_of_block_count + in + let b0, t0 = (1814, 497) in + let b1, t1 = (10031, 10337) in + let b2, t2 = (8478, 6444) in + Alcotest.(check int) "1st week" (f b0) t0; + Alcotest.(check int) "2 1st weeks" (f (b0 + b1)) (t0 + t1); + Alcotest.(check int) "3 1st weeks" (f (b0 + b1 + b2)) (t0 + t1 + t2); + Alcotest.(check int) + "2 weeks & half of one" + (f (b0 + b1 + (b2 / 2))) + (t0 + t1 + (t2 / 2)); + Alcotest.(check int) "only 3rd week" (f ~first_block_idx:(b0 + b1) b2) t2; + Alcotest.(check int) + "a third of second week" + (f ~first_block_idx:(b0 + (b1 / 3)) (b1 / 3)) + (t1 / 3); + Alcotest.(check (float 0.5e6)) + "Tx count may 5th 2021" + (f 1457727 |> float_of_int) + 15_000_000. + +let test_operation_count () = + let f = + Irmin_traces.Trace_stat_summary_utils.approx_operation_count_of_block_count + in + Alcotest.(check (float 0.5e6)) + "Ops count may 5th 2021" + (f 1457727 |> float_of_int) + 47_500_000. + +let test_cases = + [ + ("snap int", [ Alcotest.test_case "snap_around_42" `Quick snap_around_42 ]); + ( "tx count", + [ + Alcotest.test_case "test_transaction_count" `Quick + test_transaction_count; + ] ); + ( "ops count", + [ Alcotest.test_case "test_operation_count" `Quick test_operation_count ] + ); + ] diff --git a/vendors/irmin/test/irmin-bench/replay.ml b/vendors/irmin/test/irmin-bench/replay.ml new file mode 100644 index 0000000000000000000000000000000000000000..e3818f4f8dafaaa0020975b5d3b1fe5b453c2835 --- /dev/null +++ b/vendors/irmin/test/irmin-bench/replay.ml @@ -0,0 +1,182 @@ +open! Import + +let test_dir = Filename.concat "_build" "test-pack-trace-replay" + +module Conf = Irmin_tezos.Conf + +module Store = struct + type store_config = unit + + module Store = Irmin_tezos.Store + include Store + + type key = commit_key + + let create_repo ~root () = + (* make sure the parent dir exists *) + let () = + match Sys.file_exists (Filename.dirname root) with + | false -> Unix.mkdir (Filename.dirname root) 0o755 + | true -> () + in + let conf = Irmin_pack.config ~readonly:false ~fresh:true root in + let* repo = Store.Repo.v conf in + let on_commit _ _ = Lwt.return_unit in + let on_end () = Lwt.return_unit in + Lwt.return (repo, on_commit, on_end) + + let gc repo key = + let* launched = Store.start_gc ~unlink:true ~throttle:`Skip repo key in + assert launched; + let* wait = Store.finalise_gc ~wait:true repo in + assert wait; + Lwt.return_unit +end + +module Replay = Irmin_traces.Trace_replay.Make (Store) + +let rec repeat = function + | 0 -> fun _f x -> x + | n -> fun f x -> f (repeat (n - 1) f x) + +(** The current working directory depends on whether the test binary is directly + run or is triggered with [dune exec], [dune runtest]. We normalise by + switching to the project root first. *) +let goto_project_root () = + let cwd = Fpath.v (Sys.getcwd ()) in + match cwd |> Fpath.segs |> List.rev with + | "irmin-bench" :: "test" :: "default" :: "_build" :: _ -> + let root = cwd |> repeat 4 Fpath.parent in + Unix.chdir (Fpath.to_string root) + | _ -> () + +let replay_1_commit () = + goto_project_root (); + let trace_path = + let open Fpath in + v "test" / "irmin-bench" / "data" / "tezos_actions_1commit.repr" + |> to_string + in + assert (Sys.file_exists trace_path); + if Sys.file_exists test_dir then ( + let cmd = Printf.sprintf "rm -rf %s" test_dir in + [%logs.debug "exec: %s\n%!" cmd]; + let _ = Sys.command cmd in + ()); + + let replay_config : _ Replay.config = + { + number_of_commits_to_replay = 1; + path_conversion = `None; + inode_config = (Conf.entries, Conf.stable_hash); + store_type = `Pack; + replay_trace_path = trace_path; + artefacts_path = test_dir; + keep_store = false; + keep_stat_trace = false; + empty_blobs = false; + return_type = Summary; + gc_every = 0; + gc_distance_in_the_past = 0; + gc_wait_after = 0; + } + in + let+ summary = Replay.run () replay_config in + [%logs.debug + "%a" (Irmin_traces.Trace_stat_summary_pp.pp 5) ([ "" ], [ summary ])]; + let check name = Alcotest.(check int) ("Stats_counters" ^ name) in + let pack_got = Irmin_pack.Stats.get () in + let unix_got = Irmin_pack_unix.Stats.get () in + let pack_store = + Irmin_pack_unix.Stats.(Pack_store.export unix_got.pack_store) + in + let inode = Irmin_pack.Stats.(Inode.export pack_got.inode) in + check "appended_hashes" pack_store.appended_hashes 0; + check "appended_offsets" pack_store.appended_offsets 5; + check "total" pack_store.total 2; + check "from_staging" pack_store.from_staging 0; + check "from_lru" pack_store.from_lru 2; + check "from_pack_direct" pack_store.from_pack_direct 0; + check "from_pack_indexed" pack_store.from_pack_indexed 0; + check "inode_add" inode.inode_add 0; + check "inode_remove" inode.inode_remove 0; + check "inode_of_seq" inode.inode_of_seq 2; + check "inode_of_raw" inode.inode_of_raw 2; + check "inode_rec_add" inode.inode_rec_add 0; + check "inode_rec_remove" inode.inode_rec_remove 0; + check "inode_to_binv" inode.inode_to_binv 2; + check "inode_decode_bin" inode.inode_decode_bin 0; + check "inode_encode_bin" inode.inode_encode_bin 2 + +module Store_mem = struct + type store_config = unit + + module Maker = Irmin_pack_mem.Maker (Conf) + module Store = Maker.Make (Irmin_tezos.Schema) + include Store + + type key = commit_key + + let create_repo ~root () = + let conf = Irmin_pack.config ~readonly:false ~fresh:true root in + let* repo = Store.Repo.v conf in + let on_commit _ _ = Lwt.return_unit in + let on_end () = Lwt.return_unit in + Lwt.return (repo, on_commit, on_end) + + let gc repo key = + let* launched = Store.start_gc ~unlink:true ~throttle:`Skip repo key in + assert launched; + let* wait = Store.finalise_gc ~wait:true repo in + assert wait; + Lwt.return_unit +end + +module Replay_mem = Irmin_traces.Trace_replay.Make (Store_mem) + +let replay_1_commit_mem () = + goto_project_root (); + let trace_path = + let open Fpath in + v "test" / "irmin-bench" / "data" / "tezos_actions_1commit.repr" + |> to_string + in + assert (Sys.file_exists trace_path); + if Sys.file_exists test_dir then ( + let cmd = Printf.sprintf "rm -rf %s" test_dir in + [%logs.debug "exec: %s\n%!" cmd]; + let _ = Sys.command cmd in + ()); + + let replay_config : _ Irmin_traces.Trace_replay.config = + { + number_of_commits_to_replay = 1; + path_conversion = `None; + inode_config = (Conf.entries, Conf.stable_hash); + store_type = `Pack; + replay_trace_path = trace_path; + artefacts_path = test_dir; + keep_store = false; + keep_stat_trace = false; + empty_blobs = false; + return_type = Summary; + gc_every = 0; + gc_distance_in_the_past = 0; + gc_wait_after = 0; + } + in + let+ summary = Replay_mem.run () replay_config in + [%logs.debug + "%a" (Irmin_traces.Trace_stat_summary_pp.pp 5) ([ "" ], [ summary ])]; + () + +let test_cases = + [ + ( "replay", + [ + Alcotest.test_case "replay_1_commit" `Quick (fun () -> + Lwt_main.run (replay_1_commit ())); + Alcotest.test_case "replay_1_commit_in_memory" `Quick (fun () -> + Lwt_main.run (replay_1_commit_mem ())); + ] ); + ] diff --git a/vendors/irmin/test/irmin-bench/test.ml b/vendors/irmin/test/irmin-bench/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..3d09831eaf35cc55b1ae70b52e917b40bd8fbe40 --- /dev/null +++ b/vendors/irmin/test/irmin-bench/test.ml @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let () = + Alcotest.run "irmin-bench" + (Ema.test_cases @ Misc.test_cases @ Replay.test_cases) diff --git a/vendors/irmin/test/irmin-bench/test.mli b/vendors/irmin/test/irmin-bench/test.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/test/irmin-bench/test.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin-chunk/dune b/vendors/irmin/test/irmin-chunk/dune new file mode 100644 index 0000000000000000000000000000000000000000..8b275e8a8a851727e9eeaeab5d2b25afeb63e14d --- /dev/null +++ b/vendors/irmin/test/irmin-chunk/dune @@ -0,0 +1,15 @@ +(library + (name test_chunk) + (modules test_chunk) + (libraries fmt irmin irmin-test irmin-chunk irmin.mem lwt)) + +(executable + (name test) + (modules test) + (libraries alcotest fmt irmin irmin-test lwt lwt.unix test_chunk)) + +(rule + (alias runtest) + (package irmin-chunk) + (action + (run ./test.exe -q --color=always))) diff --git a/vendors/irmin/test/irmin-chunk/test.ml b/vendors/irmin/test/irmin-chunk/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..eef06a60f24c2866d6d5b838bd1e553120975206 --- /dev/null +++ b/vendors/irmin/test/irmin-chunk/test.ml @@ -0,0 +1,83 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2015 Mounir Nasr Allah + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Export_for_backends + +let () = Printexc.record_backtrace true +let key_t : Test_chunk.Key.t Alcotest.testable = (module Test_chunk.Key) +let value_t : Test_chunk.Value.t Alcotest.testable = (module Test_chunk.Value) + +let run f () = + let+ () = f () in + flush stderr; + flush stdout + +let hash x = Test_chunk.Key.hash (fun l -> l x) +let hash_contents x = hash ("B" ^ x) +let value_to_bin = Irmin.Type.(unstage (to_bin_string Test_chunk.Value.t)) + +let test_add_read ?(stable = false) (module AO : Test_chunk.S) () = + let* t = AO.v () in + let test size = + let name = Printf.sprintf "size %d" size in + let v = String.make size 'x' in + let* k = AO.batch t (fun t -> AO.add t v) in + (if stable then + let str = value_to_bin v in + Alcotest.(check key_t) (name ^ " is stable") k (hash_contents str)); + let+ v' = AO.find t k in + Alcotest.(check @@ option value_t) name (Some v) v' + in + let x = 40 in + Lwt_list.iter_s test + [ + x - 1; + x; + x + 1; + (x * 2) - 1; + x * 2; + (x * 2) + 1; + (x * x) - 1; + x * x; + (x * x) + 1; + x * x * x; + ] + +let simple = + ( "simple", + [ + ( "add/read: in-memory", + `Quick, + run @@ test_add_read (module Test_chunk.Mem) ); + ( "add/read: in-memory+chunks", + `Quick, + run @@ test_add_read (module Test_chunk.MemChunk) ); + ] ) + +let stable = + let test stable = test_add_read ~stable (module Test_chunk.MemChunk) in + ( "stable", + [ + ("add/read: simple", `Quick, run @@ test false); + ("add/read: stable", `Quick, run @@ test true); + ] ) + +let () = + Lwt_main.run + @@ Irmin_test.Store.run "irmin-chunk" ~slow:true ~misc:[ simple; stable ] + ~sleep:Lwt_unix.sleep + [ (`Quick, Test_chunk.suite) ] diff --git a/vendors/irmin/test/irmin-chunk/test.mli b/vendors/irmin/test/irmin-chunk/test.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/test/irmin-chunk/test.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin-chunk/test_chunk.ml b/vendors/irmin/test/irmin-chunk/test_chunk.ml new file mode 100644 index 0000000000000000000000000000000000000000..3469e7fb9e5bb1b0953b70b5cb42a3801637a18a --- /dev/null +++ b/vendors/irmin/test/irmin-chunk/test_chunk.ml @@ -0,0 +1,77 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2015 Mounir Nasr Allah + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Export_for_backends +module Hash = Irmin.Hash.SHA1 + +module Key = struct + include Irmin.Hash.SHA1 + + let pp = Irmin.Type.pp t + let equal = Irmin.Type.(unstage (equal t)) +end + +module Value = struct + include Irmin.Contents.String + + let pp = Fmt.string + let equal = String.equal + + type hash = Key.t + + module H = Irmin.Hash.Typed (Key) (Irmin.Contents.String) + + let hash = H.hash +end + +module type S = sig + include + Irmin.Content_addressable.S with type key = Key.t and type value = Value.t + + val v : unit -> read t Lwt.t +end + +module Append_only = Irmin_mem.Append_only + +module Content_addressable = + Irmin.Content_addressable.Make (Append_only) (Key) (Value) + +module Mem = struct + include Content_addressable + + let v () = v @@ Irmin_mem.config () +end + +module MemChunk = struct + include Content_addressable + + let small_config = + Irmin_chunk.config ~min_size:44 ~size:44 (Irmin_mem.config ()) + + let v () = v small_config +end + +let store = + Irmin_test.store + (module Irmin.Maker + (Irmin_chunk.Content_addressable + (Append_only)) + (Irmin_mem.Atomic_write)) + (module Irmin.Metadata.None) + +let config = Irmin_chunk.config (Irmin_mem.config ()) +let suite = Irmin_test.Suite.create ~name:"CHUNK" ~store ~config () diff --git a/vendors/irmin/test/irmin-cli/dune b/vendors/irmin/test/irmin-cli/dune new file mode 100644 index 0000000000000000000000000000000000000000..11ec9069d99e863e38a53e6e88c14052a53dde81 --- /dev/null +++ b/vendors/irmin/test/irmin-cli/dune @@ -0,0 +1,17 @@ +(executable + (name test) + (modules test) + (libraries irmin-cli alcotest)) + +(rule + (alias runtest) + (package irmin-cli) + (deps test.yml) + (action + (chdir + %{workspace_root} + (run %{exe:test.exe} -q --color=always)))) + +(cram + (package irmin-cli) + (deps %{bin:irmin})) diff --git a/vendors/irmin/test/irmin-cli/test.ml b/vendors/irmin/test/irmin-cli/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..8f777bb7c86db88dd8a5aa5f65a68fab5b1f262a --- /dev/null +++ b/vendors/irmin/test/irmin-cli/test.ml @@ -0,0 +1,42 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends + +module Conf = struct + let test_config () = + let hash = Irmin_cli.Resolver.Hash.find "blake2b" in + let _, cfg = + Irmin_cli.Resolver.load_config ~config_path:"test/irmin-cli/test.yml" + ~store:"pack" ~contents:"string" ~hash () + in + let spec = Irmin.Backend.Conf.spec cfg in + let index_log_size = + Irmin.Backend.Conf.get cfg Irmin_pack.Conf.Key.index_log_size + in + let fresh = Irmin.Backend.Conf.get cfg Irmin_pack.Conf.Key.fresh in + Alcotest.(check string) + "Spec name" "pack" + (Irmin.Backend.Conf.Spec.name spec); + Alcotest.(check int) "index-log-size" 1234 index_log_size; + Alcotest.(check bool) "fresh" true fresh; + Lwt.return_unit + + let misc : unit Alcotest.test_case list = + [ ("config", `Quick, fun () -> Lwt_main.run (test_config ())) ] +end + +let () = Alcotest.run "irmin-cli" [ ("conf", Conf.misc) ] diff --git a/vendors/irmin/test/irmin-cli/test.yml b/vendors/irmin/test/irmin-cli/test.yml new file mode 100644 index 0000000000000000000000000000000000000000..811f6d0324384f9f35a5f6d395fbb877d085c8eb --- /dev/null +++ b/vendors/irmin/test/irmin-cli/test.yml @@ -0,0 +1,4 @@ +store: pack +hash: blake2b +index-log-size: 1234 +fresh: true diff --git a/vendors/irmin/test/irmin-cli/test_command_line.t b/vendors/irmin/test/irmin-cli/test_command_line.t new file mode 100644 index 0000000000000000000000000000000000000000..a65906508e92253b8a600279309809b775948251 --- /dev/null +++ b/vendors/irmin/test/irmin-cli/test_command_line.t @@ -0,0 +1,96 @@ +Create default config file + $ cat > irmin.yml < root: ./test + > store: pack + > EOF + +Set a/b/c => 123 in ./test + $ irmin set a/b/c 123 + irmin: [WARNING] Updating the control file from [From_v3] to [From_v3_used_non_minimal_indexing_strategy]. It won't be possible to GC this irmin-pack store anymore. + +Set foo => bar in ./test1 + $ irmin set --root ./test1 foo bar + irmin: [WARNING] Updating the control file from [From_v3] to [From_v3_used_non_minimal_indexing_strategy]. It won't be possible to GC this irmin-pack store anymore. + +Check for a/b/c in ./test + $ irmin get --root ./test a/b/c + 123 + +Check for the non-existence of foo in ./test + $ irmin get foo + + [1] + +Check for foo in ./test1 + $ irmin get --root ./test1 foo + bar + +Try getting foo from ./test1 using the wrong store type + $ irmin get --root ./test1 -s irf foo + + [1] + +Set d/e/f => 456 in ./test + $ irmin set d/e/f 456 + +List keys in ./test + $ irmin list / + DIR a + DIR d + +List keys in ./test but no path is specified + $ irmin list + DIR a + DIR d + +Set g/h/i => 789 in ./test + $ irmin set /g/h/i/ 789 + +Snapshot main branch + $ export SNAPSHOT=`irmin snapshot` + +List keys under g/h in ./test + $ irmin list g/h + FILE i + +Remove g in ./test + $ irmin remove g + +List keys under g in ./test + $ irmin list g + +Load snapshot commit as store + $ irmin get --commit $SNAPSHOT g/h/i + 789 + +Restore snapshot + $ irmin revert $SNAPSHOT + +Get g/h/i in ./test + $ irmin get g/h/i/ + 789 + +Create branch a from main + $ irmin merge --branch a main + +Remove g/h/i in branch a + $ irmin remove --branch a /g/h/i/ + +Merge branch a in main + $ irmin merge a + +Check that g/h/i has been deleted after merge + $ irmin get g/h/i/ + + [1] + +Check mismatched hash function + $ irmin set --root ./test-hash -s irf -h sha1 abc 123 + $ irmin snapshot --root ./test-hash -s irf -h blake2b 2> /dev/null + [1] + +Clone a local repo + $ irmin clone --root ./cloned ./test + irmin: [WARNING] Updating the control file from [From_v3] to [From_v3_used_non_minimal_indexing_strategy]. It won't be possible to GC this irmin-pack store anymore. + $ irmin get --root ./cloned a/b/c + 123 diff --git a/vendors/irmin/test/irmin-containers/blob_log.ml b/vendors/irmin/test/irmin-containers/blob_log.ml new file mode 100644 index 0000000000000000000000000000000000000000..c4b4fa97e7e8e5370812eddeb1d2510e38c9e0d1 --- /dev/null +++ b/vendors/irmin/test/irmin-containers/blob_log.ml @@ -0,0 +1,90 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common +module B = Irmin_containers.Blob_log.Mem (Irmin.Contents.String) + +let path = [ "tmp"; "blob" ] +let config () = B.Store.Repo.v (Irmin_mem.config ()) +let merge_into_exn = merge_into_exn (module B.Store) + +let test_empty_read _ () = + config () + >>= B.Store.main + >>= B.read_all ~path + >|= Alcotest.(check (list string)) "checked - reading empty log" [] + +let test_append _ () = + let* t = config () >>= B.Store.main in + B.append ~path t "main.1" >>= fun () -> + B.append ~path t "main.2" >>= fun () -> + B.read_all ~path t + >|= Alcotest.(check (list string)) + "checked - log after appending" [ "main.2"; "main.1" ] + +let test_clone_merge _ () = + let* t = config () >>= B.Store.main in + let* b = B.Store.clone ~src:t ~dst:"cl" in + B.append ~path b "clone.1" >>= fun () -> + B.append ~path t "main.3" >>= fun () -> + merge_into_exn b ~into:t >>= fun () -> + B.read_all ~path t + >|= Alcotest.(check (list string)) + "checked - log after appending" + [ "main.3"; "clone.1"; "main.2"; "main.1" ] + +let test_branch_merge _ () = + let* r = config () in + let* b1 = B.Store.of_branch r "b1" in + let* b2 = B.Store.of_branch r "b2" in + let* b3 = B.Store.of_branch r "b3" in + let* b4 = B.Store.of_branch r "b4" in + B.append ~path b1 "b1.1" >>= fun () -> + B.append ~path b2 "b2.1" >>= fun () -> + B.append ~path b1 "b1.2" >>= fun () -> + B.append ~path b1 "b1.3" >>= fun () -> + B.append ~path b2 "b2.2" >>= fun () -> + B.append ~path b1 "b1.4" >>= fun () -> + merge_into_exn b1 ~into:b3 >>= fun () -> + merge_into_exn b2 ~into:b3 >>= fun () -> + merge_into_exn b2 ~into:b4 >>= fun () -> + merge_into_exn b1 ~into:b4 >>= fun () -> + let* () = + B.read_all ~path b3 + >|= Alcotest.(check (list string)) + "checked - value of b3" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + in + B.read_all ~path b4 + >|= Alcotest.(check (list string)) + "checked - value of b4" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + +let test_cases = + [ + ( "blob_log", + [ + Alcotest_lwt.test_case "Read empty log" `Quick test_empty_read; + Alcotest_lwt.test_case "Append" `Quick test_append; + ] ); + ( "blob_log store", + [ + Alcotest_lwt.test_case "Clone and merge" `Quick test_clone_merge; + Alcotest_lwt.test_case "Branch and merge" `Quick test_branch_merge; + ] ); + ] diff --git a/vendors/irmin/test/irmin-containers/common.ml b/vendors/irmin/test/irmin-containers/common.ml new file mode 100644 index 0000000000000000000000000000000000000000..530192c2aece694cf50a1bae7bdfeb92c0d6c214 --- /dev/null +++ b/vendors/irmin/test/irmin-containers/common.ml @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +let merge_into_exn (type s) (module S : Irmin.S with type t = s) store ~into = + S.merge_into ~info:S.Info.none store ~into >|= function + | Error (`Conflict msg) -> + Alcotest.failf "Encountered a conflict while merging: %s" msg + | Ok () -> () diff --git a/vendors/irmin/test/irmin-containers/common.mli b/vendors/irmin/test/irmin-containers/common.mli new file mode 100644 index 0000000000000000000000000000000000000000..f3c27a0d8559ffd5ec09b0bcfd013b16c25d3261 --- /dev/null +++ b/vendors/irmin/test/irmin-containers/common.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val merge_into_exn : + (module Irmin.S with type t = 's) -> 's -> into:'s -> unit Lwt.t diff --git a/vendors/irmin/test/irmin-containers/counter.ml b/vendors/irmin/test/irmin-containers/counter.ml new file mode 100644 index 0000000000000000000000000000000000000000..cdcac2ef9791ef4acc99b9e3842c92d377c4512a --- /dev/null +++ b/vendors/irmin/test/irmin-containers/counter.ml @@ -0,0 +1,91 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common +module C = Irmin_containers.Counter.Mem + +let path = [ "tmp"; "counter" ] +let config () = C.Store.Repo.v (Irmin_mem.config ()) +let merge_into_exn = merge_into_exn (module C.Store) + +let test_inc _ () = + let* t = config () >>= C.Store.main in + C.inc ~path t >>= fun () -> + let* () = + C.read ~path t + >|= Alcotest.(check int64) "checked - increment without using by" 1L + in + C.inc ~by:2L ~path t >>= fun () -> + C.read ~path t >|= Alcotest.(check int64) "checked - increment using by" 3L + +let test_dec _ () = + let* t = config () >>= C.Store.main in + C.dec ~path t >>= fun () -> + let* () = + C.read ~path t + >|= Alcotest.(check int64) "checked - decrement without using by" 2L + in + C.dec ~by:2L ~path t >>= fun () -> + C.read ~path t >|= Alcotest.(check int64) "checked - decrement using by" 0L + +let test_clone_merge _ () = + let* t = config () >>= C.Store.main in + C.inc ~by:5L ~path t >>= fun () -> + let* b = C.Store.clone ~src:t ~dst:"cl" in + C.inc ~by:2L ~path b >>= fun () -> + C.dec ~by:4L ~path t >>= fun () -> + let* () = + C.read ~path t >|= Alcotest.(check int64) "checked - value of main" 1L + in + let* () = + C.read ~path b >|= Alcotest.(check int64) "checked - value of clone" 7L + in + merge_into_exn b ~into:t >>= fun () -> + C.read t ~path + >|= Alcotest.(check int64) "checked - value of main after merging" 3L + +let test_branch_merge _ () = + let* r = config () in + let* b1 = C.Store.of_branch r "b1" in + let* b2 = C.Store.of_branch r "b2" in + let* b3 = C.Store.of_branch r "b3" in + let* b4 = C.Store.of_branch r "b4" in + C.inc ~by:5L ~path b1 >>= fun () -> + C.dec ~by:2L ~path b2 >>= fun () -> + merge_into_exn b1 ~into:b3 >>= fun () -> + merge_into_exn b2 ~into:b3 >>= fun () -> + merge_into_exn b2 ~into:b4 >>= fun () -> + merge_into_exn b1 ~into:b4 >>= fun () -> + let* () = + C.read ~path b3 >|= Alcotest.(check int64) "checked - value of b3" 3L + in + C.read ~path b4 >|= Alcotest.(check int64) "checked - value of b4" 3L + +let test_cases = + [ + ( "counter", + [ + Alcotest_lwt.test_case "Increment" `Quick test_inc; + Alcotest_lwt.test_case "Decrement" `Quick test_dec; + ] ); + ( "counter store", + [ + Alcotest_lwt.test_case "Clone and merge" `Quick test_clone_merge; + Alcotest_lwt.test_case "Branch and merge" `Quick test_branch_merge; + ] ); + ] diff --git a/vendors/irmin/test/irmin-containers/dune b/vendors/irmin/test/irmin-containers/dune new file mode 100644 index 0000000000000000000000000000000000000000..1d60b6a971db9b31d7dd685dd882f4afc20f50d9 --- /dev/null +++ b/vendors/irmin/test/irmin-containers/dune @@ -0,0 +1,9 @@ +(executable + (name test) + (libraries alcotest alcotest-lwt irmin-containers)) + +(rule + (alias runtest) + (package irmin-containers) + (action + (run ./test.exe -q --color=always))) diff --git a/vendors/irmin/test/irmin-containers/import.ml b/vendors/irmin/test/irmin-containers/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..e6f13c7c212906baeff59aa7fa93a8f180d08c5f --- /dev/null +++ b/vendors/irmin/test/irmin-containers/import.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/test/irmin-containers/linked_log.ml b/vendors/irmin/test/irmin-containers/linked_log.ml new file mode 100644 index 0000000000000000000000000000000000000000..08d6a7241b13d87bfe48e6e25e17e43c57041c20 --- /dev/null +++ b/vendors/irmin/test/irmin-containers/linked_log.ml @@ -0,0 +1,115 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +module CAS = struct + module Make = Irmin.Content_addressable.Make (Irmin_mem.Append_only) + + let config = Irmin_mem.config () +end + +module L = Irmin_containers.Linked_log.Mem (CAS) (Irmin.Contents.String) () + +let merge_into_exn = merge_into_exn (module L.Store) +let path = [ "tmp"; "link" ] +let config () = L.Store.Repo.v (Irmin_mem.config ()) + +let test_empty_read _ () = + config () + >>= L.Store.main + >>= L.read_all ~path + >|= Alcotest.(check (list string)) "checked - reading empty log" [] + +let test_append_read_all _ () = + let* t = config () >>= L.Store.main in + L.append ~path t "main.1" >>= fun () -> + L.append ~path t "main.2" >>= fun () -> + L.read_all ~path t + >|= Alcotest.(check (list string)) + "checked - log after appending" [ "main.2"; "main.1" ] + +let test_read_incr _ () = + let* cur = config () >>= L.Store.main >>= L.get_cursor ~path in + let* l, cur = L.read ~num_items:1 cur in + Alcotest.(check (list string)) "checked - read one item" [ "main.2" ] l; + let* l, cur = L.read ~num_items:1 cur in + Alcotest.(check (list string)) "checked - read one more item" [ "main.1" ] l; + let+ l, _ = L.read ~num_items:1 cur in + Alcotest.(check (list string)) "checked - read one more item" [] l + +let test_read_excess _ () = + let* cur = config () >>= L.Store.main >>= L.get_cursor ~path in + let+ l, _ = L.read ~num_items:10 cur in + Alcotest.(check (list string)) + "checked - read 10 items" [ "main.2"; "main.1" ] l + +let test_clone_merge _ () = + let* t = config () >>= L.Store.main in + let* b = L.Store.clone ~src:t ~dst:"cl" in + L.append ~path b "clone.1" >>= fun () -> + L.append ~path t "main.3" >>= fun () -> + merge_into_exn b ~into:t >>= fun () -> + L.read_all ~path t + >|= Alcotest.(check (list string)) + "checked - log after appending" + [ "main.3"; "clone.1"; "main.2"; "main.1" ] + +let test_branch_merge _ () = + let* r = config () in + let* b1 = L.Store.of_branch r "b1" in + let* b2 = L.Store.of_branch r "b2" in + let* b3 = L.Store.of_branch r "b3" in + let* b4 = L.Store.of_branch r "b4" in + L.append ~path b1 "b1.1" >>= fun () -> + L.append ~path b2 "b2.1" >>= fun () -> + L.append ~path b1 "b1.2" >>= fun () -> + L.append ~path b1 "b1.3" >>= fun () -> + L.append ~path b2 "b2.2" >>= fun () -> + L.append ~path b1 "b1.4" >>= fun () -> + merge_into_exn b1 ~into:b3 >>= fun () -> + merge_into_exn b2 ~into:b3 >>= fun () -> + merge_into_exn b2 ~into:b4 >>= fun () -> + merge_into_exn b1 ~into:b4 >>= fun () -> + let* () = + L.read_all ~path b3 + >|= Alcotest.(check (list string)) + "checked - value of b3" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + in + L.read_all ~path b4 + >|= Alcotest.(check (list string)) + "checked - value of b4" + [ "b1.4"; "b2.2"; "b1.3"; "b1.2"; "b2.1"; "b1.1" ] + +let test_cases = + [ + ( "linked_log", + [ + Alcotest_lwt.test_case "Read empty log" `Quick test_empty_read; + Alcotest_lwt.test_case "Append and real all" `Quick test_append_read_all; + Alcotest_lwt.test_case "Read incrementally with cursor" `Quick + test_read_incr; + Alcotest_lwt.test_case "Read excess with cursor" `Quick test_read_excess; + ] ); + ( "linked_log store", + [ + Alcotest_lwt.test_case "Clone and merge" `Quick test_clone_merge; + Alcotest_lwt.test_case "Branch and merge" `Quick test_branch_merge; + ] ); + ] diff --git a/vendors/irmin/test/irmin-containers/lww_register.ml b/vendors/irmin/test/irmin-containers/lww_register.ml new file mode 100644 index 0000000000000000000000000000000000000000..5ab78db3c2867a8c2aa01e126556025246609715 --- /dev/null +++ b/vendors/irmin/test/irmin-containers/lww_register.ml @@ -0,0 +1,96 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +module In = struct + type t = int + + let t = Irmin.Type.int +end + +module L = Irmin_containers.Lww_register.Mem (In) + +let merge_into_exn = merge_into_exn (module L.Store) +let path = [ "tmp"; "lww" ] +let config () = L.Store.Repo.v (Irmin_mem.config ()) + +let test_empty_read _ () = + config () + >>= L.Store.main + >>= L.read ~path + >|= Alcotest.(check (option int)) + "checked - reading register without writing" None + +let test_write _ () = + let* t = config () >>= L.Store.main in + L.write ~path t 1 >>= fun () -> + L.write ~path t 3 >>= fun () -> + L.read ~path t + >|= Alcotest.(check (option int)) "checked - writing to register" (Some 3) + +let test_clone_merge _ () = + let* t = config () >>= L.Store.main in + let* b = L.Store.clone ~src:t ~dst:"cl" in + L.write ~path t 5 >>= fun () -> + L.write ~path b 10 >>= fun () -> + let* () = + L.read ~path t + >|= Alcotest.(check (option int)) "checked - value of main" (Some 5) + in + let* () = + L.read ~path b + >|= Alcotest.(check (option int)) "checked - value of clone" (Some 10) + in + merge_into_exn b ~into:t >>= fun () -> + L.read ~path t + >|= Alcotest.(check (option int)) + "checked - value of main after merging" (Some 10) + +let test_branch_merge _ () = + let* r = config () in + let* b1 = L.Store.of_branch r "b1" in + let* b2 = L.Store.of_branch r "b2" in + let* b3 = L.Store.of_branch r "b3" in + let* b4 = L.Store.of_branch r "b4" in + L.write ~path b1 6 >>= fun () -> + L.write ~path b2 3 >>= fun () -> + merge_into_exn b1 ~into:b3 >>= fun () -> + merge_into_exn b2 ~into:b3 >>= fun () -> + merge_into_exn b2 ~into:b4 >>= fun () -> + merge_into_exn b1 ~into:b4 >>= fun () -> + let* () = + L.read ~path b3 + >|= Alcotest.(check (option int)) "checked - value of b3" (Some 3) + in + L.read ~path b4 + >|= Alcotest.(check (option int)) "checked - value of b4" (Some 3) + +let test_cases = + [ + ( "lww_register", + [ + Alcotest_lwt.test_case "Read" `Quick test_empty_read; + Alcotest_lwt.test_case "Write" `Quick test_write; + ] ); + ( "lww_register store", + [ + Alcotest_lwt.test_case "Clone and merge" `Quick test_clone_merge; + Alcotest_lwt.test_case "Branch and merge" `Quick test_branch_merge; + ] ); + ] diff --git a/vendors/irmin/test/irmin-containers/test.ml b/vendors/irmin/test/irmin-containers/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..50483d8ed186656759b5a369abd2f7500b9bb969 --- /dev/null +++ b/vendors/irmin/test/irmin-containers/test.ml @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let () = + Lwt_main.run + @@ Alcotest_lwt.run "irmin-containers" + (Counter.test_cases + @ Lww_register.test_cases + @ Blob_log.test_cases + @ Linked_log.test_cases) diff --git a/vendors/irmin/test/irmin-containers/test.mli b/vendors/irmin/test/irmin-containers/test.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/test/irmin-containers/test.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin-fs/dune b/vendors/irmin/test/irmin-fs/dune new file mode 100644 index 0000000000000000000000000000000000000000..87614dbcb5d81e8bfc672bc57a318ba25e1abf41 --- /dev/null +++ b/vendors/irmin/test/irmin-fs/dune @@ -0,0 +1,31 @@ +(library + (name test_fs) + (modules test_fs) + (libraries irmin-fs irmin-test lwt)) + +(library + (name test_fs_unix) + (modules test_fs_unix) + (libraries test_fs irmin irmin-fs.unix irmin-test irmin-watcher lwt)) + +(executable + (name test) + (modules test) + (libraries alcotest lwt.unix irmin irmin-test test_fs)) + +(executable + (name test_unix) + (modules test_unix) + (libraries alcotest irmin irmin-test test_fs_unix)) + +(rule + (alias runtest) + (package irmin-fs) + (action + (run %{exe:test.exe} -q --color=always))) + +(rule + (alias runtest) + (package irmin-fs) + (action + (run %{exe:test_unix.exe} -q --color=always))) diff --git a/vendors/irmin/test/irmin-fs/test.ml b/vendors/irmin/test/irmin-fs/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..2ab8c18fcef2b755c6fb3af6fb551e6af9b91ece --- /dev/null +++ b/vendors/irmin/test/irmin-fs/test.ml @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let () = + Lwt_main.run + @@ Irmin_test.Store.run "irmin-fs" ~slow:true ~misc:[] ~sleep:Lwt_unix.sleep + [ (`Quick, Test_fs.suite) ] diff --git a/vendors/irmin/test/irmin-fs/test.mli b/vendors/irmin/test/irmin-fs/test.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/test/irmin-fs/test.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin-fs/test_fs.ml b/vendors/irmin/test/irmin-fs/test_fs.ml new file mode 100644 index 0000000000000000000000000000000000000000..f87198ac92c4805557c0556cc131d2d929c033b4 --- /dev/null +++ b/vendors/irmin/test/irmin-fs/test_fs.ml @@ -0,0 +1,28 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt.Infix +module IO = Irmin_fs.IO_mem + +let test_db = Filename.concat "_build" "test-db" +let init ~config:_ = IO.clear () >|= fun () -> IO.set_listen_hook () +let config = Irmin_fs.config test_db +let clean ~config:_ = Lwt.return_unit + +let store = + Irmin_test.store (module Irmin_fs.Maker (IO)) (module Irmin.Metadata.None) + +let suite = Irmin_test.Suite.create ~name:"FS" ~init ~store ~config ~clean () diff --git a/vendors/irmin/test/irmin-fs/test_fs_unix.ml b/vendors/irmin/test/irmin-fs/test_fs_unix.ml new file mode 100644 index 0000000000000000000000000000000000000000..01aef3c06b95a3ed32e9189e88e703432ad73339 --- /dev/null +++ b/vendors/irmin/test/irmin-fs/test_fs_unix.ml @@ -0,0 +1,45 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let stats () = + let stats = Irmin_watcher.stats () in + (stats.Irmin_watcher.watchdogs, Irmin.Backend.Watch.workers ()) + +let test_db = Test_fs.test_db +let config = Test_fs.config +let store = Irmin_test.store (module Irmin_fs_unix) (module Irmin.Metadata.None) + +let clean_dirs config = + let test_db = + Irmin.Backend.Conf.find_root config |> Option.value ~default:test_db + in + if Sys.file_exists test_db then + let cmd = Printf.sprintf "rm -rf %s" test_db in + let _ = Sys.command cmd in + () + +let init ~config = + clean_dirs config; + Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook; + Lwt.return_unit + +let clean ~config = + clean_dirs config; + Irmin.Backend.Watch.(set_listen_dir_hook none); + Lwt.return_unit + +let suite = + Irmin_test.Suite.create ~name:"FS.UNIX" ~init ~store ~config ~clean ~stats () diff --git a/vendors/irmin/test/irmin-fs/test_unix.ml b/vendors/irmin/test/irmin-fs/test_unix.ml new file mode 100644 index 0000000000000000000000000000000000000000..1bc071b6392d33cdd4bd0ce5badd50a5a5db3972 --- /dev/null +++ b/vendors/irmin/test/irmin-fs/test_unix.ml @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2013-2021 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let () = + Lwt_main.run + @@ Irmin_test.Store.run "irmin-fs.unix" ~slow:false ~sleep:Lwt_unix.sleep + ~misc:[] + [ (`Quick, Test_fs_unix.suite) ] diff --git a/vendors/irmin/test/irmin-git/dune b/vendors/irmin/test/irmin-git/dune new file mode 100644 index 0000000000000000000000000000000000000000..7bd68385fba75ae76fa9771184aad7879da6a9ef --- /dev/null +++ b/vendors/irmin/test/irmin-git/dune @@ -0,0 +1,46 @@ +(library + (name test_git) + (modules test_git) + (libraries + alcotest + fmt + fpath + irmin + irmin-test + irmin.mem + irmin-git + git + git-unix + lwt + lwt.unix) + (preprocess + (pps ppx_irmin ppx_irmin.internal))) + +(library + (name test_git_unix) + (modules test_git_unix) + (libraries test_git irmin.unix irmin-git.unix irmin-watcher) + (preprocess + (pps ppx_irmin ppx_irmin.internal))) + +(executable + (name test) + (modules test) + (libraries alcotest irmin irmin-test test_git)) + +(executable + (name test_unix) + (modules test_unix) + (libraries alcotest irmin irmin-test test_git_unix)) + +(rule + (alias runtest) + (package irmin-git) + (action + (run %{exe:test.exe} -q --color=always))) + +(rule + (alias runtest) + (package irmin-git) + (action + (run %{exe:test_unix.exe} -q --color=always))) diff --git a/vendors/irmin/test/irmin-git/test.ml b/vendors/irmin/test/irmin-git/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..154b15db4c04efa24b3eb3f2a02cebda4060d08f --- /dev/null +++ b/vendors/irmin/test/irmin-git/test.ml @@ -0,0 +1,22 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let misc = [ ("misc", Test_git.(misc mem)) ] + +let () = + Lwt_main.run + @@ Irmin_test.Store.run "irmin-git" ~slow:true ~misc ~sleep:Lwt_unix.sleep + [ (`Quick, Test_git.suite); (`Quick, Test_git.suite_generic) ] diff --git a/vendors/irmin/test/irmin-git/test.mli b/vendors/irmin/test/irmin-git/test.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/test/irmin-git/test.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin-git/test_git.ml b/vendors/irmin/test/irmin-git/test_git.ml new file mode 100644 index 0000000000000000000000000000000000000000..1fae8fa6ccc7b69689c871efbd3c5316f8700433 --- /dev/null +++ b/vendors/irmin/test/irmin-git/test_git.ml @@ -0,0 +1,240 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Export_for_backends + +let test_db = Filename.concat "_build" "test-db-git" + +let config = + let head = Git.Reference.v "refs/heads/test" in + Irmin_git.config ~head ~bare:true test_db + +module type S = sig + include Irmin_test.S + + val init : config:Irmin.config -> unit Lwt.t +end + +module type G = sig + include S + module Git : Irmin_git.G +end + +module X = struct + type t = X of (int * int) | Y of string list [@@deriving irmin] + + let merge = Irmin.Merge.idempotent [%typ: t option] +end + +module type X = + Irmin.S + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Contents.t = X.t + and type Schema.Branch.t = string + +module Mem (C : Irmin.Contents.S) = struct + module G = Irmin_git.Mem + module M = Irmin_git.KV (G) (Git_unix.Sync (G)) + module S = M.Make (C) + include S + + let init ~config = + let test_db = + Irmin.Backend.Conf.find_root config |> Option.value ~default:test_db + in + Git.v (Fpath.v test_db) >>= function + | Ok t -> S.Git.reset t >|= fun _ -> () + | _ -> Lwt.return_unit +end + +module Generic (C : Irmin.Contents.S) = struct + module CA = Irmin.Content_addressable.Make (Irmin_mem.Append_only) + module M = Irmin_git.Generic_KV (CA) (Irmin_mem.Atomic_write) + include M.Make (C) + + let init ~config = + let* repo = Repo.v config in + Repo.branches repo >>= Lwt_list.iter_p (Branch.remove repo) + + let clean ~config = + let* repo = Repo.v config in + Repo.branches repo >>= Lwt_list.iter_p (Branch.remove repo) >>= fun () -> + Repo.close repo +end + +let suite = + let module S = Mem (Irmin.Contents.String) in + let store = (module S : Irmin_test.S) in + let init ~config = S.init ~config in + let clean ~config = S.init ~config in + Irmin_test.Suite.create ~name:"GIT" ~init ~store ~config ~clean () + +let suite_generic = + let module S = Generic (Irmin.Contents.String) in + let store = (module S : Irmin_test.S) in + let clean ~config = S.clean ~config in + let init ~config = S.init ~config in + Irmin_test.Suite.create ~name:"GIT.generic" ~init ~store ~config ~clean () + +let get = function Some x -> x | None -> Alcotest.fail "get" + +let test_sort_order (module S : S) = + let config = Irmin_git.config test_db in + S.init ~config >>= fun () -> + let* repo = S.Repo.v config in + let commit_t = S.Backend.Repo.commit_t repo in + let node_t = S.Backend.Repo.node_t repo in + let head_tree_id branch = + let* head = S.Head.get branch in + let+ commit = S.Backend.Commit.find commit_t (S.Commit.hash head) in + S.Backend.Commit.Val.node (get commit) + in + let ls branch = + let* tree_id = head_tree_id branch in + let+ tree = S.Backend.Node.find node_t tree_id in + S.Backend.Node.Val.list (get tree) |> List.map fst + in + let info = S.Info.none in + let* main = S.main repo in + S.remove_exn main ~info [] >>= fun () -> + S.set_exn main ~info [ "foo.c" ] "foo.c" >>= fun () -> + S.set_exn main ~info [ "foo1" ] "foo1" >>= fun () -> + S.set_exn main ~info [ "foo"; "foo.o" ] "foo.o" >>= fun () -> + let* items = ls main in + Alcotest.(check (list string)) "Sort order" [ "foo.c"; "foo"; "foo1" ] items; + let* tree_id = head_tree_id main in + Alcotest.(check string) + "Sort hash" "00c5f5e40e37fde61911f71373813c0b6cad1477" + (Irmin.Type.to_string S.Backend.Node.Key.t tree_id); + + (* Convert dir to file; changes order in listing *) + S.set_exn main ~info [ "foo" ] "foo" >>= fun () -> + let* items = ls main in + Alcotest.(check (list string)) "Sort order" [ "foo"; "foo.c"; "foo1" ] items; + Lwt.return_unit + +module Ref (S : Irmin_git.G) = struct + module M = Irmin_git.Ref (S) (Git_unix.Sync (S)) + include M.Make (Irmin.Contents.String) +end + +let pp_reference ppf = function + | `Branch s -> Fmt.pf ppf "branch: %s" s + | `Remote s -> Fmt.pf ppf "remote: %s" s + | `Tag s -> Fmt.pf ppf "tag: %s" s + | `Other s -> Fmt.pf ppf "other: %s" s + +let reference = Alcotest.testable pp_reference ( = ) + +let test_list_refs (module S : G) = + let module R = Ref (S.Git) in + let config = Irmin_git.config test_db in + S.init ~config >>= fun () -> + let* repo = R.Repo.v config in + let* main = R.main repo in + R.set_exn main ~info:R.Info.none [ "test" ] "toto" >>= fun () -> + let* head = R.Head.get main in + R.Branch.set repo (`Remote "datakit/main") head >>= fun () -> + R.Branch.set repo (`Other "foo/bar/toto") head >>= fun () -> + R.Branch.set repo (`Branch "foo") head >>= fun () -> + let* bs = R.Repo.branches repo in + Alcotest.(check (slist reference compare)) + "raw branches" + [ + `Branch "foo"; + `Branch "main"; + `Other "foo/bar/toto"; + `Remote "datakit/main"; + ] + bs; + let* repo = S.Repo.v (Irmin_git.config test_db) in + let* bs = S.Repo.branches repo in + Alcotest.(check (slist string String.compare)) + "filtered branches" [ "main"; "foo" ] bs; + + (* XXX: re-add + if S.Git.kind = `Disk then + let i = Fmt.kstr Sys.command "cd %s && git gc" test_db in + if i <> 0 then Alcotest.fail "git gc failed"; + S.Repo.branches repo >|= fun bs -> + Alcotest.(check (slist string String.compare)) "filtered branches" + ["main";"foo"] bs + else *) + Lwt.return_unit + +let bin_string = Alcotest.testable (Fmt.fmt "%S") ( = ) + +let pre_hash t v = + let buf = Buffer.create 13 in + let pre_hash = Irmin.Type.(unstage (pre_hash t)) in + pre_hash v (Buffer.add_string buf); + Buffer.contents buf + +let test_blobs (module S : S) = + let str = pre_hash S.Contents.t "foo" in + Alcotest.(check bin_string) "blob foo" "blob 3\000foo" str; + let str = pre_hash S.Contents.t "" in + Alcotest.(check bin_string) "blob ''" "blob 0\000" str; + let module X = Mem (X) in + let str = pre_hash X.Contents.t (Y [ "foo"; "bar" ]) in + Alcotest.(check bin_string) + "blob foo" "blob 19\000{\"Y\":[\"foo\",\"bar\"]}" str; + let str = pre_hash X.Contents.t (X (1, 2)) in + Alcotest.(check bin_string) "blob ''" "blob 11\000{\"X\":[1,2]}" str; + let t = X.Tree.singleton [ "foo" ] (X (1, 2)) in + let k1 = X.Tree.hash t in + let* repo = X.Repo.v (Irmin_git.config test_db) in + let* k2 = + X.Backend.Repo.batch repo (fun x y _ -> X.save_tree ~clear:false repo x y t) + >|= function + | `Node k -> k + | `Contents k -> k + in + let hash = Irmin_test.testable X.Hash.t in + Alcotest.(check hash) "blob" k1 k2; + Lwt.return_unit + +let test_import_export (module S : S) = + let module Generic = Generic (Irmin.Contents.String) in + let module Sync = Irmin.Sync.Make (Generic) in + let config = Irmin_git.config test_db in + S.init ~config >>= fun () -> + let* _ = Generic.init ~config in + let* repo = S.Repo.v config in + let* t = S.main repo in + S.set_exn t ~info:S.Info.none [ "test" ] "toto" >>= fun () -> + let remote = Irmin.remote_store (module S) t in + let* repo = Generic.Repo.v (Irmin_mem.config ()) in + let* t = Generic.main repo in + let* _ = Sync.pull_exn t remote `Set in + let+ toto = Generic.get t [ "test" ] in + Alcotest.(check string) "import" toto "toto" + +let misc (module S : G) = + let s = (module S : S) in + let g = (module S : G) in + let generic = (module Generic (Irmin.Contents.String) : S) in + [ + ("Testing sort order", `Quick, fun () -> test_sort_order s); + ("Testing sort order (generic)", `Quick, fun () -> test_sort_order generic); + ("Testing listing refs", `Quick, fun () -> test_list_refs g); + ("git -> mem", `Quick, fun () -> test_import_export s); + ("git blobs", `Quick, fun () -> test_blobs s); + ("git blobs of generic", `Quick, fun () -> test_blobs s); + ] + +let mem = (module Mem (Irmin.Contents.String) : G) diff --git a/vendors/irmin/test/irmin-git/test_git.mli b/vendors/irmin/test/irmin-git/test_git.mli new file mode 100644 index 0000000000000000000000000000000000000000..6191323f9acbd01f145748986459964260a073ac --- /dev/null +++ b/vendors/irmin/test/irmin-git/test_git.mli @@ -0,0 +1,33 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val suite : Irmin_test.Suite.t +val suite_generic : Irmin_test.Suite.t +val test_db : string + +module type S = sig + include Irmin_test.S + + val init : config:Irmin.config -> unit Lwt.t +end + +module type G = sig + include S + module Git : Irmin_git.G +end + +val misc : (module G) -> unit Alcotest_lwt.test_case list +val mem : (module G) diff --git a/vendors/irmin/test/irmin-git/test_git_unix.ml b/vendors/irmin/test/irmin-git/test_git_unix.ml new file mode 100644 index 0000000000000000000000000000000000000000..afeecf9ba8d6a4f33fa133aeb532d87ef03a70d0 --- /dev/null +++ b/vendors/irmin/test/irmin-git/test_git_unix.ml @@ -0,0 +1,55 @@ +include Irmin.Export_for_backends + +let stats () = + let stats = Irmin_watcher.stats () in + (stats.Irmin_watcher.watchdogs, Irmin.Backend.Watch.workers ()) + +let test_db = Test_git.test_db + +let init ~config = + let test_db = + Irmin.Backend.Conf.find_root config |> Option.value ~default:test_db + in + assert (test_db <> ".git"); + let+ () = + if Sys.file_exists test_db then + Git_unix.Store.v (Fpath.v test_db) >>= function + | Ok t -> Git_unix.Store.reset t >|= fun _ -> () + | Error _ -> Lwt.return_unit + else Lwt.return_unit + in + Irmin.Backend.Watch.set_listen_dir_hook Irmin_watcher.hook + +module S = struct + module G = Git_unix.Store + include Irmin_git_unix.FS.KV (Irmin.Contents.String) + + let init = init +end + +let store = (module S : Test_git.G) + +let clean ~config:_ = + Irmin.Backend.Watch.(set_listen_dir_hook none); + Lwt.return_unit + +let config = + let head = Git.Reference.v "refs/heads/test" in + Irmin_git.config ~head ~bare:true test_db + +let suite = + let store = (module S : Irmin_test.S) in + Irmin_test.Suite.create ~name:"GIT.UNIX" ~init ~store ~config ~clean ~stats () + +let test_non_bare () = + let config = Irmin_git.config ~bare:false test_db in + init ~config >>= fun () -> + let info = Irmin_git_unix.info in + let* repo = S.Repo.v config in + let* t = S.main repo in + S.set_exn t ~info:(info "fst one") [ "fst" ] "ok" >>= fun () -> + S.set_exn t ~info:(info "snd one") [ "fst"; "snd" ] "maybe?" >>= fun () -> + S.set_exn t ~info:(info "fst one") [ "fst" ] "hoho" + +let misc : unit Alcotest.test_case list = + [ ("non-bare", `Quick, fun () -> Lwt_main.run (test_non_bare ())) ] diff --git a/vendors/irmin/test/irmin-git/test_unix.ml b/vendors/irmin/test/irmin-git/test_unix.ml new file mode 100644 index 0000000000000000000000000000000000000000..9e3157ec8f41a7030d0d16f4350eb79a475e4746 --- /dev/null +++ b/vendors/irmin/test/irmin-git/test_unix.ml @@ -0,0 +1,23 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let misc = [ ("misc", Test_git.misc Test_git_unix.store) ] +let suites = [ (`Quick, Test_git_unix.suite) ] + +let () = + Lwt_main.run + @@ Irmin_test.Store.run "irmin-git.unix" ~misc ~slow:false + ~sleep:Lwt_unix.sleep suites diff --git a/vendors/irmin/test/irmin-graphql/common.ml b/vendors/irmin/test/irmin-graphql/common.ml new file mode 100644 index 0000000000000000000000000000000000000000..b5e6109c5a5d705b3a2f0082ac44d4d28a552d04 --- /dev/null +++ b/vendors/irmin/test/irmin-graphql/common.ml @@ -0,0 +1,197 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module Store = Irmin_mem.KV.Make (Irmin.Contents.String) + +let ( / ) = Filename.concat +let http_graphql_dir = "test-graphql" +let socket = http_graphql_dir / "irmin.sock" +let host = "irmin" + +let ctx = + let resolver = + let h = Hashtbl.create 1 in + Hashtbl.add h host (`Unix_domain_socket socket); + Resolver_lwt_unix.static h + in + Cohttp_lwt_unix.Client.custom_ctx ~resolver () + +module Server = + Irmin_graphql_unix.Server.Make + (Store) + (struct + let remote = None + end) + +let mkdir d = + Lwt.catch + (fun () -> Lwt_unix.mkdir d 0o755) + (function + | Unix.Unix_error (Unix.EEXIST, _, _) -> Lwt.return_unit | e -> Lwt.fail e) + +(** Create a GraphQL server over the supplied Irmin repository, returning the + event loop thread. *) +let server_of_repo : type a. Store.repo -> a Lwt.t = + fun repo -> + let server = Server.v repo in + let* () = + Lwt.catch + (fun () -> Lwt_unix.unlink socket) + (function Unix.Unix_error _ -> Lwt.return_unit | e -> Lwt.fail e) + in + mkdir http_graphql_dir >>= fun () -> + let on_exn = raise and mode = `Unix_domain_socket (`File socket) in + Cohttp_lwt_unix.Server.create ~on_exn ~mode server >>= fun () -> + Lwt.fail_with "GraphQL server terminated unexpectedly" + +type server = { event_loop : 'a. 'a Lwt.t; store : Store.t } + +let spawn_graphql_server () = + let config = Irmin_mem.config () in + let* repo = Store.Repo.v config in + let+ main = Store.main repo in + let event_loop = server_of_repo repo in + { event_loop; store = main } + +let rec retry n f = + let retries = ref 0 in + Lwt.catch f (fun e -> + if n = 0 then Lwt.fail e + else + Lwt_unix.sleep (0.1 *. float !retries) >>= fun () -> + incr retries; + retry (n + 1) f) + +type param = + | Var of string + | Raw of string + | String of string + | Int of int + | Float of float + +type query = + | Mutation of query + | Query of query + | List of query list + | Func of string * (string * param) list * query + | Field of string + +let rec string_of_query = function + | Query q -> Printf.sprintf "query { %s }" (string_of_query q) + | Mutation q -> Printf.sprintf "mutation { %s }" (string_of_query q) + | List ql -> String.concat "\n" (List.map string_of_query ql) + | Func (name, params, query) -> ( + match params with + | [] -> Printf.sprintf "%s { %s }" name (string_of_query query) + | args -> + Printf.sprintf "%s (%s) { %s }" name (string_of_args args) + (string_of_query query)) + | Field s -> s + +and string_of_args args = + List.map + (fun (k, v) -> + let v = + match v with + | Var s -> "$" ^ s + | String s -> "\"" ^ s ^ "\"" + | Raw s -> s + | Int i -> string_of_int i + | Float f -> string_of_float f + in + k ^ ": " ^ v) + args + |> String.concat ", " + +let query q = Query q +let mutation q = Mutation q +let list l = List l +let func name ?(params = []) q = Func (name, params, q) +let field s = Field s +let string s = String s +let raw s = Raw s +let var s = Var s +let int i = Int i +let float f = Float f + +let find_result res x = + let rec aux (res : Yojson.Safe.t) x = + match res with + | `List l -> `List (List.map (fun res -> aux res x) l) + | `Assoc _ -> ( + match x with + | Query q | Mutation q -> aux (Yojson.Safe.Util.member "data" res) q + | Func (name, _, q) -> aux (Yojson.Safe.Util.member name res) q + | Field name -> Yojson.Safe.Util.member name res + | List l -> + `Assoc + (List.map + (function + | Field name as item -> (name, aux res item) + | Func (name, _, _) as item -> (name, aux res item) + | _ -> assert false) + l)) + | x -> x + in + aux res x + +(** Issue a query to the localhost server and return the body of the response + message *) +let send_query : + ?vars:(string * Yojson.Safe.t) list -> + string -> + (string, [ `Msg of string ]) result Lwt.t = + fun ?(vars = []) query -> + let headers = Cohttp.Header.init_with "Content-Type" "application/json" + and body = + Yojson.Safe.to_string + (`Assoc [ ("query", `String query); ("variables", `Assoc vars) ]) + |> Cohttp_lwt.Body.of_string + in + let* response, body = + retry 10 (fun () -> + Cohttp_lwt_unix.Client.post ~headers ~body ~ctx + (Uri.make ~scheme:"http" ~host ~path:"graphql" ())) + in + let status = Cohttp_lwt.Response.status response in + let+ body = Cohttp_lwt.Body.to_string body in + match Cohttp.Code.(status |> code_of_status |> is_success) with + | true -> Ok body + | false -> + let msg = + Format.sprintf "Response: %s\nBody:\n%s" + (Cohttp.Code.string_of_status status) + body + in + Error (`Msg msg) + +let members keys json = + List.fold_left (fun key json -> Yojson.Safe.Util.member json key) json keys + +let parse_result k f res = f (members k res) + +(** Issue a query to the localhost server, parse the response object and convert + it using [f] *) +let exec ?vars query f = + let* res = send_query ?vars (string_of_query query) in + match res with + | Error (`Msg e) -> Alcotest.fail e + | Ok res -> + let res = Yojson.Safe.from_string res in + let value = find_result res query in + print_endline (Yojson.Safe.to_string value); + Lwt.return (f value) diff --git a/vendors/irmin/test/irmin-graphql/common.mli b/vendors/irmin/test/irmin-graphql/common.mli new file mode 100644 index 0000000000000000000000000000000000000000..59d6b3159a79c1ec9007fcf08afac9d22259733f --- /dev/null +++ b/vendors/irmin/test/irmin-graphql/common.mli @@ -0,0 +1,141 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Default Irmin GraphQL store *) +module Store : + Irmin.S + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Contents.t = string + and type Schema.Metadata.t = unit + and type Schema.Branch.t = string + +type server = { + event_loop : 'a. 'a Lwt.t; + (** The server runtime. Cancelling this thread terminates the server. *) + store : Store.t; (** The store used by the server *) +} + +val spawn_graphql_server : unit -> server Lwt.t +(** Initialise a GraphQL server. At most one server may be running concurrently. *) + +type param +(** Parameter to GraphQL function *) + +val var : string -> param +(** Variable parameter *) + +val string : string -> param +(** String parameter, a string with quotation marks added *) + +val raw : string -> param +(** Raw parameter, will be sent without any modification *) + +val int : int -> param +(** Int parameter *) + +val float : float -> param +(** Float parameter *) + +type query +(** GraphQL query + + All queries will begin with either [query] or [mutation], and contain a + combination of [list], [func] and [field]. + + For example, the following query returns the latest commit hash for the + [main] branch: + + {[ + query (func "main" (field "hash")) + ]} + + To avoid nesting parenthesis, you can use the [@@] operator to chain + expressions: + + {[ + query @@ func "main" @@ field "hash" + ]} *) + +val query : query -> query +(** Start a query + + In GraphQL: [query { ... }] *) + +val mutation : query -> query +(** Start a mutation + + In GraphQL: [mutation { ... }] *) + +val list : query list -> query +(** List of [field] or [func] + + + In GraphQL: {[ + { + ... + } + ]} +*) + +val func : string -> ?params:(string * param) list -> query -> query +(** GraphQL method + + In GraphQL: {[ + func(params...) { + ... + } + ]} + + Without parameters: {[ + func { + ... + } + ]} + *) + +val field : string -> query +(** Named field/attribute + + In GraphQL: {[ + { + field + } + ]} + *) + +val string_of_query : query -> string +(** Convert [query] to [string] *) + +val send_query : + ?vars:(string * Yojson.Safe.t) list -> + string -> + (string, [ `Msg of string ]) result Lwt.t +(** Send a GraphQL query string to the currently running test GraphQL instance. *) + +val members : string list -> Yojson.Safe.t -> Yojson.Safe.t +(** Get key from JSON object *) + +val parse_result : string list -> (Yojson.Safe.t -> 'a) -> Yojson.Safe.t -> 'a +(** Get key from JSON object and apply conversion function *) + +val exec : + ?vars:(string * Yojson.Safe.t) list -> + query -> + (Yojson.Safe.t -> 'a) -> + 'a Lwt.t +(** Send a [query] to the running GraphQL instance and parse the JSON results + using the provided conversion function *) diff --git a/vendors/irmin/test/irmin-graphql/dune b/vendors/irmin/test/irmin-graphql/dune new file mode 100644 index 0000000000000000000000000000000000000000..5f8d03744e67610ca0c064da0ce42b78289f6ce8 --- /dev/null +++ b/vendors/irmin/test/irmin-graphql/dune @@ -0,0 +1,19 @@ +(executable + (name test) + (modules test common import) + (libraries + alcotest + alcotest-lwt + yojson + irmin + irmin-graphql.unix + irmin.mem + cohttp-lwt-unix + logs.fmt + logs)) + +(rule + (alias runtest) + (package irmin-graphql) + (action + (run ./test.exe -q --color=always))) diff --git a/vendors/irmin/test/irmin-graphql/import.ml b/vendors/irmin/test/irmin-graphql/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..e6f13c7c212906baeff59aa7fa93a8f180d08c5f --- /dev/null +++ b/vendors/irmin/test/irmin-graphql/import.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/test/irmin-graphql/test.ml b/vendors/irmin/test/irmin-graphql/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..ab82b49e4a363b9cd65ee19d18d58d44bc7409c1 --- /dev/null +++ b/vendors/irmin/test/irmin-graphql/test.ml @@ -0,0 +1,293 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +module Json = struct + include Yojson.Safe + include Yojson.Safe.Util +end + +type concrete = Store.Tree.concrete + +module Alcotest = struct + include Alcotest + + let yojson = testable Json.pp Json.equal +end + +(** Helpers for constructing data *) + +(** Tree with a single child *) +let stree only_key only_child = `Tree [ (only_key, only_child) ] + +(** Sequence of nested trees each with exactly one child *) +let strees : string list -> concrete -> concrete = List.fold_right stree + +let contents v = `Contents (v, ()) + +let set_tree store tree = + Store.Tree.of_concrete tree + |> Store.set_tree_exn ~info:Store.Info.none store [] + +type test_case = Store.t -> unit Lwt.t + +let test_get_contents_list : test_case = + fun store -> + let data = strees [ "a"; "b"; "c" ] (contents "data") + and query = + query + @@ func "main" + @@ func "tree" + @@ func "get_contents" + ~params:[ ("path", string "a/b/c") ] + (list [ field "path"; field "__typename" ]) + in + set_tree store data >>= fun () -> + let+ (result : (string * Json.t) list) = exec query Json.to_assoc in + Alcotest.(check (list (pair string yojson))) + "Returned entry data is valid" + [ ("path", `String "/a/b/c"); ("__typename", `String "Contents") ] + result; + () + +let test_list_contents_recursively : test_case = + fun store -> + let* () = + Store.set_exn store [ "a"; "b"; "c" ] "data" ~info:Store.Info.none + in + let* () = + Store.set_exn store [ "a"; "b"; "d" ] "data1" ~info:Store.Info.none + in + let q = + query + @@ func "main" + @@ func "tree" + @@ func "list_contents_recursively" (list [ field "path"; field "value" ]) + in + let+ contents = exec q Json.to_list >|= List.map Json.to_assoc in + Alcotest.(check (list (list (pair string yojson)))) + "Contents list matches" + [ + [ ("path", `String "/a/b/c"); ("value", `String "data") ]; + [ ("path", `String "/a/b/d"); ("value", `String "data1") ]; + ] + contents + +let test_get_tree_list : test_case = + fun store -> + let data = + strees [ "a"; "b"; "c" ] + (`Tree + [ ("leaf", contents "data1"); ("branch", stree "f" (contents "data2")) ]) + and query = + query + @@ func "main" + @@ func "tree" + @@ func "get_tree" ~params:[ ("path", string "a/b/c") ] + @@ func "list" (list [ field "path"; field "__typename" ]) + in + set_tree store data >>= fun () -> + let+ path_data = exec query Json.(fun x -> to_list x |> List.map to_assoc) in + Alcotest.(check (list (list (pair string yojson)))) + "Returned entry data is valid" + [ + [ ("path", `String "/a/b/c/branch"); ("__typename", `String "Tree") ]; + [ ("path", `String "/a/b/c/leaf"); ("__typename", `String "Contents") ]; + ] + path_data; + () + +let test_get_last_modified : test_case = + fun store -> + let data = stree "a" (contents "data") + and query = + query + @@ func "main" + @@ func "last_modified" + ~params:[ ("path", string "a"); ("n", int 1); ("depth", int 1) ] + @@ func "tree" + @@ func "get_contents" + ~params:[ ("path", string "a") ] + (list [ field "value"; field "__typename" ]) + in + set_tree store data >>= fun () -> + let+ result = exec query Json.(fun m -> to_list m |> List.map to_assoc) in + Alcotest.(check (list (list (pair string yojson)))) + "Returned entry data is valid " + [ [ ("value", `String "data"); ("__typename", `String "Contents") ] ] + result; + () + +let test_commit : test_case = + fun _ -> + let query0 = + query @@ func "main" @@ func "head" (list [ field "hash"; field "key" ]) + in + let* result = exec query0 Json.to_assoc in + let hash = List.assoc "hash" result |> Json.to_string in + let key = List.assoc "key" result |> Json.to_string in + let query1 = + query @@ func "commit_of_key" ~params:[ ("key", var "key") ] @@ field "hash" + in + let vars = [ ("key", `String key) ] in + let+ hash' = exec ~vars query1 Json.to_string in + Alcotest.(check string) "Hashes equal" hash hash' + +let test_mutation : test_case = + fun store -> + let m = + mutation + @@ func "set" ~params:[ ("path", string "foo"); ("value", string "bar") ] + @@ field "hash" + in + let* _hash = exec m Json.to_string in + let q = + query + @@ func "main" + @@ func "tree" + @@ func "get_contents" ~params:[ ("path", string "foo") ] + @@ field "value" + in + let* value = Store.get store [ "foo" ] in + let+ result' = exec q Json.to_string in + Alcotest.(check string) "Contents equal" "bar" result'; + Alcotest.(check string) "Contents equal stored value" "bar" value + +let test_update_tree : test_case = + fun store -> + let* commit = Store.Head.get store in + let hash = Store.Commit.hash commit |> Irmin.Type.to_string Store.hash_t in + let m = + mutation + @@ func "update_tree" ~params:[ ("path", string "/"); ("tree", raw "[]") ] + @@ field "hash" + in + let* hash' = exec m Json.to_string in + Alcotest.(check string) "Hashes equal" hash hash'; + let m = + mutation + @@ func "update_tree" + ~params: + [ + ("path", string "/"); + ("tree", raw {| [{path: "foo", value: "bar1"}] |}); + ] + @@ field "hash" + in + let* hash' = exec m Json.to_string in + if String.equal hash hash' then + Alcotest.fail "Hashes should not be equal after update"; + let* contents = Store.get store [ "foo" ] in + Alcotest.(check string) "Contents at foo" contents "bar1"; + let m = + mutation + @@ func "update_tree" + ~params:[ ("path", string "/"); ("tree", raw {| [{path: "foo"}] |}) ] + @@ field "hash" + in + let* () = exec m ignore in + let+ contents = Store.find store [ "foo" ] in + Alcotest.(check (option string)) "Contents empty after update" contents None + +let test_remove : test_case = + fun store -> + let info () = Store.Info.v 0L in + let path_param = string "test/remove" in + let* () = Store.set_exn store [ "test"; "remove" ] "XXX" ~info in + let m = + mutation @@ func "remove" ~params:[ ("path", path_param) ] @@ field "hash" + in + let* () = exec m ignore in + let q = + query + @@ func "main" + @@ func "tree" + @@ func "get_contents" ~params:[ ("path", path_param) ] + @@ field "value" + in + let+ c = exec q Json.to_string_option in + Alcotest.(check (option string)) "Contents have been removed" c None + +let test_branch_list : test_case = + fun store -> + let repo = Store.repo store in + let* head = Store.Head.get store in + let* () = Store.Branch.set repo "A" head in + let* () = Store.Branch.set repo "B" head in + let q = query @@ func "branches" @@ list [ field "name" ] in + let+ branches = + exec q (fun x -> + Json.to_list x |> List.map Json.to_assoc |> List.map List.hd) + in + let branches = + List.sort + (fun (_, a) (_, b) -> + String.compare (Json.to_string a) (Json.to_string b)) + branches + in + Alcotest.(check (list (pair string yojson))) + "Check branch list" branches + [ ("name", `String "A"); ("name", `String "B"); ("name", `String "main") ] + +let test_revert store = + let* head = Store.Head.get store in + let parents = Store.Commit.parents head in + let parent = List.hd parents in + let parent_s = Irmin.Type.to_string Store.hash_t parent in + let q = + mutation + @@ func "revert" ~params:[ ("commit", string parent_s) ] + @@ field "hash" + in + let* hash = exec q Json.to_string in + Alcotest.(check string) "hash is parent hash" hash parent_s; + let+ new_head = Store.Head.get store in + let new_hash = + Store.Commit.hash new_head |> Irmin.Type.to_string Store.hash_t + in + Alcotest.(check string) "parent is new head" parent_s new_hash + +let suite store = + let test_case : string -> test_case -> unit Alcotest_lwt.test_case = + fun name f -> Alcotest_lwt.test_case name `Quick (fun _ () -> f store) + in + [ + ( "GRAPHQL", + [ + test_case "get_contents-list" test_get_contents_list; + test_case "list_contents_recursively" test_list_contents_recursively; + test_case "get_tree-list" test_get_tree_list; + test_case "get_last_modified" test_get_last_modified; + test_case "commit" test_commit; + test_case "mutation" test_mutation; + test_case "update_tree" test_update_tree; + test_case "remove" test_remove; + test_case "branches" test_branch_list; + test_case "revert" test_revert; + ] ); + ] + +let () = + Random.self_init (); + Logs.set_reporter (Logs_fmt.reporter ()); + Logs.set_level (Some Debug); + let main = + let* { event_loop; store } = spawn_graphql_server () in + Lwt.pick [ event_loop; Alcotest_lwt.run "irmin-graphql" (suite store) ] + in + Lwt_main.run main diff --git a/vendors/irmin/test/irmin-graphql/test.mli b/vendors/irmin/test/irmin-graphql/test.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/test/irmin-graphql/test.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin-http/dune b/vendors/irmin/test/irmin-http/dune new file mode 100644 index 0000000000000000000000000000000000000000..72c03033ce78ab9a34a7b392d14ab41ff5dfb22b --- /dev/null +++ b/vendors/irmin/test/irmin-http/dune @@ -0,0 +1,37 @@ +(library + (name test_http) + (modules test_http) + (libraries + alcotest + cohttp-lwt + cohttp-lwt-unix + conduit + conduit-lwt-unix + fmt + irmin-test + test_mem + test_git + test_fs_unix + test_git_unix + irmin + irmin-http.unix + logs + lwt + lwt.unix + uri) + (preprocess + (pps ppx_irmin.internal))) + +(executable + (name test) + (modules test) + (libraries irmin-test test_http)) + +(rule + (alias runtest) + (package irmin-http) + (locks ../http) + (action + (chdir + %{workspace_root} + (run %{exe:test.exe} -q --color=always)))) diff --git a/vendors/irmin/test/irmin-http/test.ml b/vendors/irmin/test/irmin-http/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..7f7f4950e2bb22d91b943297aa396c2a76971b6f --- /dev/null +++ b/vendors/irmin/test/irmin-http/test.ml @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let () = + Test_http.(with_server servers) (fun () -> + Irmin_test.Store.run "irmin-http" ~misc:[] ~sleep:Lwt_unix.sleep + Test_http.(suites servers)) diff --git a/vendors/irmin/test/irmin-http/test.mli b/vendors/irmin/test/irmin-http/test.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/test/irmin-http/test.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin-http/test_http.ml b/vendors/irmin/test/irmin-http/test_http.ml new file mode 100644 index 0000000000000000000000000000000000000000..999675740a75f66d058ec82214a45f893088794f --- /dev/null +++ b/vendors/irmin/test/irmin-http/test_http.ml @@ -0,0 +1,238 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Export_for_backends + +let () = Random.self_init () +let ( / ) = Filename.concat +let test_http_dir = "test-http" +let uri = Uri.of_string "http://irmin" + +type id = { name : string; id : int } + +let pp ppf t = Fmt.pf ppf "%s-%d" t.name t.id +let socket t = test_http_dir / Fmt.str "irmin-%a.sock" pp t +let pid_file t = test_http_dir / Fmt.str "irmin-test-%a.pid" pp t +let tmp_file file = file ^ ".tmp" + +module Client = Irmin_http_unix.Http_client + +module Sock (P : sig + val id : id +end) = +struct + let sock = socket P.id +end + +let http_store id (module S : Irmin_test.S) = + let module P = Sock (struct + let id = id + end) in + let module M = Irmin_http.Client (Client (P)) (S) in + (module M : Irmin_test.S) + +let remove file = try Unix.unlink file with _ -> () + +let check_connection id = + let module Client = Client (Sock (struct + let id = id + end)) in + let ctx = Client.ctx () in + let rec loop n = + let url = + Uri.of_string ("http://irmin/branch/CHECK-CONNECTION-" ^ string_of_int n) + in + if n > 10 then + Alcotest.failf "Cannot connect to server %a: too many retries" pp id + else + Lwt.try_bind + (fun () -> Client.get ?ctx url) + (fun _ -> Lwt.return ()) + (function + | Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> + Lwt_unix.sleep (float n *. 0.1) >>= fun () -> loop (n + 1) + | e -> + Alcotest.failf "Cannot connect to server %a: %a" pp id Fmt.exn e) + in + loop 1 + +let wait_for_the_server_to_start id = + let rec aux n = + let pid_file = pid_file id in + let socket = socket id in + if Sys.file_exists pid_file && Sys.file_exists socket then ( + let ic = open_in pid_file in + let line = input_line ic in + close_in ic; + let pid = int_of_string line in + [%logs.debug "read PID %d from %s" pid pid_file]; + Unix.unlink pid_file; + check_connection id >|= fun () -> pid) + else ( + [%logs.debug "waiting for the server to start..."]; + Lwt_unix.sleep (float n *. 0.1) >>= fun () -> aux (n + 1)) + in + aux 1 + +let servers = + [ + (`Quick, Test_mem.suite); + (`Quick, Test_git.suite); + (`Quick, Test_fs_unix.suite); + (`Quick, Test_git_unix.suite); + ] + +module Conf = Irmin_http.Conf + +let root c = Irmin.Backend.Conf.(get c (root Irmin_http.Conf.spec)) + +let mkdir d = + Lwt.catch + (fun () -> Lwt_unix.mkdir d 0o755) + (function + | Unix.Unix_error (Unix.EEXIST, _, _) -> Lwt.return_unit | e -> Lwt.fail e) + +let rec lock id = + let pid = string_of_int (Unix.getpid ()) in + let pid_len = String.length pid in + let pid_file = pid_file id in + let pid_file_tmp = tmp_file pid_file in + (* [fd] is used to write the actual PID file; the file is renamed + bellow to ensure atomicity. *) + let* fd = + Lwt_unix.openfile pid_file_tmp [ Unix.O_CREAT; Unix.O_RDWR ] 0o600 + in + Lwt.catch + (fun () -> + Lwt_unix.lockf fd Unix.F_LOCK 0 >>= fun () -> + [%logs.debug "write PID %s in %s" pid pid_file]; + let* len = Lwt_unix.write fd (Bytes.of_string pid) 0 pid_len in + if len <> pid_len then + Lwt_unix.close fd >>= fun () -> + Lwt.fail_with "Unable to write PID to lock file" + else Lwt_unix.rename pid_file_tmp pid_file >|= fun () -> fd) + (function + | Unix.Unix_error (Unix.EAGAIN, _, _) -> + Lwt_unix.close fd >>= fun () -> lock id + | e -> Lwt_unix.close fd >>= fun () -> Lwt.fail e) + +let unlock fd = Lwt_unix.close fd + +let get_store suite = + match Irmin_test.Suite.store suite with + | Some x -> x + | None -> + failwith + "Cannot construct `irmin-http` test suite for non-content-addressable \ + backend. Pass a store of type `Irmin.S`." + +let serve servers n id = + Logs.set_level ~all:true (Some Logs.Debug); + [%logs.debug "pwd: %s" @@ Unix.getcwd ()]; + let _, (server : Irmin_test.Suite.t) = List.nth servers n in + [%logs.debug + "Got server: %s, root=%s" + (Irmin_test.Suite.name server) + (root (Irmin_test.Suite.config server))]; + let (module Server : Irmin_test.S) = get_store server in + let module HTTP = Irmin_http_unix.Server (Server) in + let test = { name = Irmin_test.Suite.name server; id } in + let socket = socket test in + let server () = + let config = Irmin_test.Suite.config server in + Irmin_test.Suite.init server ~config >>= fun () -> + let* repo = Server.Repo.v config in + let* lock = lock test in + let spec = HTTP.v repo ~strict:false in + let* () = + Lwt.catch + (fun () -> Lwt_unix.unlink socket) + (function Unix.Unix_error _ -> Lwt.return_unit | e -> Lwt.fail e) + in + let mode = `Unix_domain_socket (`File socket) in + Conduit_lwt_unix.set_max_active 100; + let* () = + Cohttp_lwt_unix.Server.create + ~on_exn:(Fmt.pr "Async exception caught: %a" Fmt.exn) + ~mode spec + in + unlock lock + in + Lwt_main.run (server ()) + +let kill_server socket pid = + let () = + try + Unix.kill pid Sys.sigkill; + try ignore (Unix.waitpid [ Unix.WUNTRACED ] pid) with _ -> () + with Unix.Unix_error (Unix.ESRCH, _, _) -> () + in + Unix.unlink socket; + Fmt.epr "Server [PID %d] is killed.\n%!" pid + +let suite i server = + let id = + { name = Irmin_test.Suite.name server; id = Random.int 0x3FFFFFFF } + in + let socket = socket id in + let server_pid = ref 0 in + let config = + Irmin_http.config uri (Irmin.Backend.Conf.empty Irmin_http.Conf.spec) + in + Irmin_test.Suite.create + ~name:(Printf.sprintf "HTTP.%s" (Irmin_test.Suite.name server)) + ~init:(fun ~config:_ -> + remove socket; + remove (pid_file id); + mkdir test_http_dir >>= fun () -> + Lwt_io.flush_all () >>= fun () -> + let pwd = Sys.getcwd () in + let root = + if Filename.basename pwd = "default" then ".." / ".." / "" else "" + in + let cmd = + root + ^ "_build" + / "default" + / Fmt.str "%s serve %d %d &" Sys.argv.(0) i id.id + in + Fmt.epr "pwd=%s\nExecuting: %S\n%!" pwd cmd; + let _ = Sys.command cmd in + let+ pid = wait_for_the_server_to_start id in + server_pid := pid) + ~clean:(fun ~config -> + kill_server socket !server_pid; + Irmin_test.Suite.clean server ~config) + ~config + ~store:(http_store id (get_store server)) + () + +let suites servers = + if Sys.os_type = "Win32" then + (* it's a bit hard to test client/server stuff on windows because + we can't fork. Can work around that later if needed. *) + [] + else List.mapi (fun i (s, server) -> (s, suite i server)) servers + +let with_server servers f = + if Array.length Sys.argv = 4 && Sys.argv.(1) = "serve" then ( + let n = int_of_string Sys.argv.(2) in + let id = int_of_string Sys.argv.(3) in + Logs.set_reporter (Irmin_test.reporter ~prefix:"S" ()); + serve servers n id) + else Lwt_main.run (f ()) + +type test = Alcotest.speed_level * Irmin_test.Suite.t diff --git a/vendors/irmin/test/irmin-http/test_http.mli b/vendors/irmin/test/irmin-http/test_http.mli new file mode 100644 index 0000000000000000000000000000000000000000..f9541ffbf1d382454dc344871464831e94faf756 --- /dev/null +++ b/vendors/irmin/test/irmin-http/test_http.mli @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +type test = Alcotest.speed_level * Irmin_test.Suite.t + +val servers : test list +val suites : test list -> test list +val with_server : test list -> (unit -> unit Lwt.t) -> unit diff --git a/vendors/irmin/test/irmin-mem/bench.ml b/vendors/irmin/test/irmin-mem/bench.ml new file mode 100644 index 0000000000000000000000000000000000000000..c4bc86d41e5741fc544e88930967c33632e63152 --- /dev/null +++ b/vendors/irmin/test/irmin-mem/bench.ml @@ -0,0 +1,23 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let config ~root:_ = Irmin_mem.config () + +module KV = Irmin_mem.KV.Make (Irmin.Contents.String) +module Bench = Irmin_bench.Make (KV) + +let size ~root:_ = 0 +let () = Bench.run ~config ~size diff --git a/vendors/irmin/test/irmin-mem/dune b/vendors/irmin/test/irmin-mem/dune new file mode 100644 index 0000000000000000000000000000000000000000..1f548b95c10df8ad5f469f9c357455b184fad0c8 --- /dev/null +++ b/vendors/irmin/test/irmin-mem/dune @@ -0,0 +1,20 @@ +(library + (name test_mem) + (modules test_mem) + (libraries irmin irmin-test irmin.mem lwt)) + +(executable + (name test) + (modules test) + (libraries alcotest lwt.unix irmin-test test_mem)) + +(rule + (alias runtest) + (package irmin-test) + (action + (run ./test.exe -q --color=always))) + +(executable + (name bench) + (modules bench) + (libraries irmin.mem irmin-test.bench)) diff --git a/vendors/irmin/test/irmin-mem/test.ml b/vendors/irmin/test/irmin-mem/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..e2d99e032ff9d404bc5cade11301f18ce5ffc2ad --- /dev/null +++ b/vendors/irmin/test/irmin-mem/test.ml @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let () = + Lwt_main.run + @@ Irmin_test.Store.run "irmin-mem" ~slow:true ~misc:[] ~sleep:Lwt_unix.sleep + [ (`Quick, Test_mem.suite) ] diff --git a/vendors/irmin/test/irmin-mem/test.mli b/vendors/irmin/test/irmin-mem/test.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/test/irmin-mem/test.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin-mem/test_mem.ml b/vendors/irmin/test/irmin-mem/test_mem.ml new file mode 100644 index 0000000000000000000000000000000000000000..bf8c5b13cd355bf5de5806c7b23e5cbae6a54016 --- /dev/null +++ b/vendors/irmin/test/irmin-mem/test_mem.ml @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let store = Irmin_test.store (module Irmin_mem) (module Irmin.Metadata.None) +let config = Irmin_mem.config () +let init ~config:_ = Lwt.return_unit +let suite = Irmin_test.Suite.create ~name:"MEM" ~init ~store ~config () diff --git a/vendors/irmin/test/irmin-pack/_layered.mli b/vendors/irmin/test/irmin-pack/_layered.mli new file mode 100644 index 0000000000000000000000000000000000000000..2b40d2f8916f782670b0f185413a252210411567 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/_layered.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val tests : unit Alcotest.test_case list diff --git a/vendors/irmin/test/irmin-pack/common.ml b/vendors/irmin/test/irmin-pack/common.ml new file mode 100644 index 0000000000000000000000000000000000000000..612c31b4dc615dace4654eb9fd2bbc51bfcb7def --- /dev/null +++ b/vendors/irmin/test/irmin-pack/common.ml @@ -0,0 +1,342 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Export_for_backends +module Int63 = Optint.Int63 + +let get = function Some x -> x | None -> Alcotest.fail "None" +let sha1 x = Irmin.Hash.SHA1.hash (fun f -> f x) +let sha1_contents x = sha1 ("B" ^ x) + +let rm_dir root = + if Sys.file_exists root then ( + let cmd = Printf.sprintf "rm -rf %s" root in + [%logs.info "exec: %s\n%!" cmd]; + let _ = Sys.command cmd in + ()) + +let index_log_size = Some 1_000 +let () = Random.self_init () +let random_char () = char_of_int (Random.int 256) +let random_string n = String.init n (fun _i -> random_char ()) +let random_letter () = char_of_int (Char.code 'a' + Random.int 26) +let random_letters n = String.init n (fun _i -> random_letter ()) + +module Conf = Irmin_tezos.Conf + +module Schema = struct + open Irmin + module Metadata = Metadata.None + module Contents = Contents.String_v2 + module Path = Path.String_list + module Branch = Branch.String + module Hash = Hash.SHA1 + module Node = Node.Generic_key.Make_v2 (Hash) (Path) (Metadata) + module Commit = Commit.Generic_key.Make_v2 (Hash) + module Info = Info.Default +end + +module Contents = struct + include Irmin.Contents.String + + let kind _ = Irmin_pack.Pack_value.Kind.Contents + + module H = Irmin.Hash.Typed (Irmin.Hash.SHA1) (Irmin.Contents.String) + + let hash = H.hash + let magic = 'B' + let encode_triple = Irmin.Type.(unstage (encode_bin (triple H.t char t))) + let decode_triple = Irmin.Type.(unstage (decode_bin (triple H.t char t))) + let length_header = Fun.const (Some `Varint) + let encode_bin ~dict:_ ~offset_of_key:_ k x = encode_triple (k, magic, x) + + let decode_bin ~dict:_ ~key_of_offset:_ ~key_of_hash:_ x pos_ref = + let _, _, v = decode_triple x pos_ref in + v + + let decode_bin_length = + match Irmin.Type.(Size.of_encoding (triple H.t char t)) with + | Dynamic f -> f + | _ -> assert false +end + +module I = Irmin_pack_unix.Index +module Index = Irmin_pack_unix.Index.Make (Schema.Hash) +module Key = Irmin_pack.Pack_key.Make (Schema.Hash) +module Io = Irmin_pack_unix.Io.Unix +module Errs = Irmin_pack_unix.Io_errors.Make (Io) +module Control = Irmin_pack_unix.Control_file.Make (Io) +module Aof = Irmin_pack_unix.Append_only_file.Make (Io) + +module File_manager = + Irmin_pack_unix.File_manager.Make (Control) (Aof) (Aof) (Index) (Errs) + +module Dict = Irmin_pack_unix.Dict.Make (File_manager) +module Dispatcher = Irmin_pack_unix.Dispatcher.Make (File_manager) + +module Pack = + Irmin_pack_unix.Pack_store.Make (File_manager) (Dict) (Dispatcher) + (Schema.Hash) + (Contents) + (Errs) + +module Branch = + Irmin_pack_unix.Atomic_write.Make_persistent + (Irmin.Branch.String) + (Irmin_pack.Atomic_write.Value.Of_hash (Schema.Hash)) + +module Make_context (Config : sig + val root : string +end) = +struct + let fresh_name = + let c = ref 0 in + fun object_type -> + incr c; + + let name = Filename.concat Config.root ("pack_" ^ string_of_int !c) in + [%logs.info "Constructing %s context object: %s" object_type name]; + name + + let mkdir_dash_p dirname = Irmin_pack_unix.Io_legacy.Unix.mkdir dirname + + type d = { name : string; fm : File_manager.t; dict : Dict.t } + + (* TODO : test the indexing_strategy minimal. *) + let config ~readonly ~fresh name = + Irmin_pack.Conf.init ~fresh ~readonly + ~indexing_strategy:Irmin_pack.Indexing_strategy.always ~lru_size:0 name + + (* TODO : remove duplication with irmin_pack/ext.ml *) + let get_fm config = + let readonly = Irmin_pack.Conf.readonly config in + if readonly then File_manager.open_ro config |> Errs.raise_if_error + else + let fresh = Irmin_pack.Conf.fresh config in + if fresh then ( + let root = Irmin_pack.Conf.root config in + mkdir_dash_p root; + File_manager.create_rw ~overwrite:true config |> Errs.raise_if_error) + else File_manager.open_rw config |> Errs.raise_if_error + + let get_dict ?name ~readonly ~fresh () = + let name = Option.value name ~default:(fresh_name "dict") in + let fm = config ~readonly ~fresh name |> get_fm in + let dict = Dict.v fm |> Errs.raise_if_error in + { name; dict; fm } + + let close_dict d = File_manager.close d.fm |> Errs.raise_if_error + + type t = { + name : string; + fm : File_manager.t; + index : Index.t; + pack : read Pack.t; + dict : Pack.dict; + } + + let create ~readonly ~fresh name = + let f = ref (fun () -> ()) in + let config = config ~readonly ~fresh name in + let fm = get_fm config in + let dispatcher = Dispatcher.v ~root:name fm |> Errs.raise_if_error in + (* open the index created by the fm. *) + let index = File_manager.index fm in + let dict = Dict.v fm |> Errs.raise_if_error in + let pack = Pack.v ~config ~fm ~dict ~dispatcher in + (f := fun () -> File_manager.flush fm |> Errs.raise_if_error); + { name; index; pack; dict; fm } |> Lwt.return + + let get_rw_pack () = + let name = fresh_name "" in + create ~readonly:false ~fresh:true name + + let get_ro_pack name = create ~readonly:true ~fresh:false name + let reopen_rw name = create ~readonly:false ~fresh:false name + + let close_pack t = + Index.close_exn t.index; + File_manager.close t.fm |> Errs.raise_if_error; + (* closes pack and dict *) + Lwt.return_unit +end + +module Alcotest = struct + include Alcotest + + let int63 = testable Int63.pp Int63.equal + + (** TODO: upstream this to Alcotest *) + let check_raises_lwt msg exn (type a) (f : unit -> a Lwt.t) = + Lwt.catch + (fun x -> + let* (_ : a) = f x in + Alcotest.failf + "Fail %s: expected function to raise %s, but it returned instead." msg + (Printexc.to_string exn)) + (function + | e when e = exn -> Lwt.return_unit + | e -> + Alcotest.failf + "Fail %s: expected function to raise %s, but it raised %s \ + instead." + msg (Printexc.to_string exn) (Printexc.to_string e)) + + let testable_repr t = + Alcotest.testable (Irmin.Type.pp t) Irmin.Type.(unstage (equal t)) + + let check_repr ?pos t = Alcotest.check ?pos (testable_repr t) + let kind = testable_repr Irmin_pack.Pack_value.Kind.t + let hash = testable_repr Schema.Hash.t +end + +module Filename = struct + include Filename + + (** Extraction from OCaml for pre-4.10 compatibility *) + + let generic_quote quotequote s = + let l = String.length s in + let b = Buffer.create (l + 20) in + Buffer.add_char b '\''; + for i = 0 to l - 1 do + if s.[i] = '\'' then Buffer.add_string b quotequote + else Buffer.add_char b s.[i] + done; + Buffer.add_char b '\''; + Buffer.contents b + + let quote_command = + match Sys.os_type with + | "Win32" -> + let quote s = + let l = String.length s in + let b = Buffer.create (l + 20) in + Buffer.add_char b '\"'; + let rec loop i = + if i = l then Buffer.add_char b '\"' + else + match s.[i] with + | '\"' -> loop_bs 0 i + | '\\' -> loop_bs 0 i + | c -> + Buffer.add_char b c; + loop (i + 1) + and loop_bs n i = + if i = l then ( + Buffer.add_char b '\"'; + add_bs n) + else + match s.[i] with + | '\"' -> + add_bs ((2 * n) + 1); + Buffer.add_char b '\"'; + loop (i + 1) + | '\\' -> loop_bs (n + 1) (i + 1) + | _ -> + add_bs n; + loop i + and add_bs n = + for _j = 1 to n do + Buffer.add_char b '\\' + done + in + loop 0; + Buffer.contents b + in + let quote_cmd s = + let b = Buffer.create (String.length s + 20) in + String.iter + (fun c -> + match c with + | '(' | ')' | '!' | '^' | '%' | '\"' | '<' | '>' | '&' | '|' -> + Buffer.add_char b '^'; + Buffer.add_char b c + | _ -> Buffer.add_char b c) + s; + Buffer.contents b + in + let quote_cmd_filename f = + if String.contains f '\"' || String.contains f '%' then + failwith ("Filename.quote_command: bad file name " ^ f) + else if String.contains f ' ' then "\"" ^ f ^ "\"" + else f + in + fun cmd ?stdin ?stdout ?stderr args -> + String.concat "" + [ + "\""; + quote_cmd_filename cmd; + " "; + quote_cmd (String.concat " " (List.map quote args)); + (match stdin with + | None -> "" + | Some f -> " <" ^ quote_cmd_filename f); + (match stdout with + | None -> "" + | Some f -> " >" ^ quote_cmd_filename f); + (match stderr with + | None -> "" + | Some f -> + if stderr = stdout then " 2>&1" + else " 2>" ^ quote_cmd_filename f); + "\""; + ] + | _ -> ( + let quote = generic_quote "'\\''" in + fun cmd ?stdin ?stdout ?stderr args -> + String.concat " " (List.map quote (cmd :: args)) + ^ (match stdin with None -> "" | Some f -> " <" ^ quote f) + ^ (match stdout with None -> "" | Some f -> " >" ^ quote f) + ^ + match stderr with + | None -> "" + | Some f -> if stderr = stdout then " 2>&1" else " 2>" ^ quote f) +end + +(** Exec a command, and return [Ok ()] or [Error n] if return code is n <> 0 *) +let exec_cmd cmd = + [%logs.info "exec: %s" cmd]; + match Sys.command cmd with 0 -> Ok () | n -> Error n + +let rec repeat = function + | 0 -> fun _f x -> x + | n -> fun f x -> f (repeat (n - 1) f x) + +(** The current working directory depends on whether the test binary is directly + run or is triggered with [dune exec], [dune runtest]. We normalise by + switching to the project root first. *) +let goto_project_root () = + let cwd = Fpath.v (Sys.getcwd ()) in + match cwd |> Fpath.segs |> List.rev with + | "irmin-pack" :: "test" :: "default" :: "_build" :: _ -> + let root = cwd |> repeat 4 Fpath.parent in + Unix.chdir (Fpath.to_string root) + | _ -> () + +let setup_test_env ~root_archive ~root_local_build = + goto_project_root (); + rm_dir root_local_build; + let cmd = + Filename.quote_command "cp" [ "-R"; "-p"; root_archive; root_local_build ] + in + exec_cmd cmd |> function + | Ok () -> () + | Error n -> + Fmt.failwith + "Failed to set up the test environment: command `%s' exited with \ + non-zero exit code %d" + cmd n diff --git a/vendors/irmin/test/irmin-pack/common.mli b/vendors/irmin/test/irmin-pack/common.mli new file mode 100644 index 0000000000000000000000000000000000000000..535dd4bd3fc76d8b0ddbe45172bf2bf97b0eaeff --- /dev/null +++ b/vendors/irmin/test/irmin-pack/common.mli @@ -0,0 +1,115 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Perms +module Int63 = Optint.Int63 +module Dict : Irmin_pack_unix.Dict.S +module I = Irmin_pack_unix.Index +module Conf : Irmin_pack.Conf.S + +module File_manager : + Irmin_pack_unix.File_manager.S with module Io = Irmin_pack_unix.Io.Unix + +module Errs : + Irmin_pack_unix.Io_errors.S with module Io = Irmin_pack_unix.Io.Unix + +module Schema : + Irmin.Schema.Extended + with type Hash.t = Irmin.Hash.SHA1.t + and type Path.step = string + and type Path.t = string list + and type Branch.t = string + and type Contents.t = string + and type Metadata.t = unit + +module Filename : sig + include module type of Filename + + val quote_command : + string -> + ?stdin:string -> + ?stdout:string -> + ?stderr:string -> + string list -> + string +end + +module Alcotest : sig + include module type of Alcotest + + val int63 : Int63.t testable + val kind : Irmin_pack.Pack_value.Kind.t testable + val hash : Schema.Hash.t testable + val check_raises_lwt : string -> exn -> (unit -> _ Lwt.t) -> unit Lwt.t + + val check_repr : + ?pos:Source_code_position.pos -> + 'a Irmin.Type.t -> + string -> + 'a -> + 'a -> + unit +end + +module Index : module type of Irmin_pack_unix.Index.Make (Schema.Hash) +module Key : Irmin_pack.Pack_key.S with type hash = Schema.Hash.t + +module Pack : + Irmin_pack_unix.Pack_store.S + with type hash = Schema.Hash.t + and type key = Key.t + and type value = string + +(** Helper constructors for fresh pre-initialised dictionaries and packs *) +module Make_context (Config : sig + val root : string +end) : sig + val fresh_name : string -> string + (** [fresh_name typ] is a clean directory for a resource of type [typ]. *) + + type d = { name : string; fm : File_manager.t; dict : Dict.t } + + val get_dict : ?name:string -> readonly:bool -> fresh:bool -> unit -> d + val close_dict : d -> unit + + type t = { + name : string; + fm : File_manager.t; + index : Index.t; + pack : read Pack.t; + dict : Dict.t; + } + + val get_rw_pack : unit -> t Lwt.t + val get_ro_pack : string -> t Lwt.t + val reopen_rw : string -> t Lwt.t + val close_pack : t -> unit Lwt.t +end + +val get : 'a option -> 'a +val sha1 : string -> Schema.Hash.t +val sha1_contents : string -> Schema.Hash.t +val rm_dir : string -> unit +val index_log_size : int option +val random_string : int -> string +val random_letters : int -> string + +val exec_cmd : string -> (unit, int) result +(** Exec a command, and return [Ok ()] or [Error n] if return code is n <> 0 *) + +val setup_test_env : root_archive:string -> root_local_build:string -> unit +(** [setup_test_env ~root_archive ~root_local_build] copies an existing store to + a temporary location, to be used by the test. *) diff --git a/vendors/irmin/test/irmin-pack/data/corrupted/index/log b/vendors/irmin/test/irmin-pack/data/corrupted/index/log new file mode 100644 index 0000000000000000000000000000000000000000..6ee5a62f71f90724821fb068bc05b940708aad23 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/corrupted/index/log differ diff --git a/vendors/irmin/test/irmin-pack/data/corrupted/store.branches b/vendors/irmin/test/irmin-pack/data/corrupted/store.branches new file mode 100644 index 0000000000000000000000000000000000000000..b35ec9eb8604d06cc073c4477be60528e1fc5a7a Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/corrupted/store.branches differ diff --git a/vendors/irmin/test/irmin-pack/data/corrupted/store.dict b/vendors/irmin/test/irmin-pack/data/corrupted/store.dict new file mode 100644 index 0000000000000000000000000000000000000000..b35ec9eb8604d06cc073c4477be60528e1fc5a7a Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/corrupted/store.dict differ diff --git a/vendors/irmin/test/irmin-pack/data/corrupted/store.pack b/vendors/irmin/test/irmin-pack/data/corrupted/store.pack new file mode 100644 index 0000000000000000000000000000000000000000..c629ec67ac7292fa0c073b1a0a36dc255fcfdda3 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/corrupted/store.pack differ diff --git a/vendors/irmin/test/irmin-pack/data/corrupted_inode/index/log b/vendors/irmin/test/irmin-pack/data/corrupted_inode/index/log new file mode 100644 index 0000000000000000000000000000000000000000..73803a19fcd76206e7c773816ce14199a527e72d Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/corrupted_inode/index/log differ diff --git a/vendors/irmin/test/irmin-pack/data/corrupted_inode/store.branches b/vendors/irmin/test/irmin-pack/data/corrupted_inode/store.branches new file mode 100644 index 0000000000000000000000000000000000000000..026861d446725b5c7c6e5e0ebc2be0a9394ceff4 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/corrupted_inode/store.branches differ diff --git a/vendors/irmin/test/irmin-pack/data/corrupted_inode/store.dict b/vendors/irmin/test/irmin-pack/data/corrupted_inode/store.dict new file mode 100644 index 0000000000000000000000000000000000000000..10ff4b264c8e9fd2f5547ec1a4db97b535e0cfa3 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/corrupted_inode/store.dict differ diff --git a/vendors/irmin/test/irmin-pack/data/corrupted_inode/store.pack b/vendors/irmin/test/irmin-pack/data/corrupted_inode/store.pack new file mode 100644 index 0000000000000000000000000000000000000000..53567bd5bf6feb48bf72739428a3f78c1c8e5a0c Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/corrupted_inode/store.pack differ diff --git a/vendors/irmin/test/irmin-pack/data/empty_store/index/log b/vendors/irmin/test/irmin-pack/data/empty_store/index/log new file mode 100644 index 0000000000000000000000000000000000000000..2efae83b38b46071f0240e4667e72cedf6c4a007 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/empty_store/index/log differ diff --git a/vendors/irmin/test/irmin-pack/data/empty_store/store.branches b/vendors/irmin/test/irmin-pack/data/empty_store/store.branches new file mode 100644 index 0000000000000000000000000000000000000000..b35ec9eb8604d06cc073c4477be60528e1fc5a7a Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/empty_store/store.branches differ diff --git a/vendors/irmin/test/irmin-pack/data/empty_store/store.dict b/vendors/irmin/test/irmin-pack/data/empty_store/store.dict new file mode 100644 index 0000000000000000000000000000000000000000..b35ec9eb8604d06cc073c4477be60528e1fc5a7a Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/empty_store/store.dict differ diff --git a/vendors/irmin/test/irmin-pack/data/empty_store/store.pack b/vendors/irmin/test/irmin-pack/data/empty_store/store.pack new file mode 100644 index 0000000000000000000000000000000000000000..b35ec9eb8604d06cc073c4477be60528e1fc5a7a Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/empty_store/store.pack differ diff --git a/vendors/irmin/test/irmin-pack/data/version_1/index/log b/vendors/irmin/test/irmin-pack/data/version_1/index/log new file mode 100644 index 0000000000000000000000000000000000000000..d34a3e30a6b93a0efe28310c4903f93c2bc20e3f Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_1/index/log differ diff --git a/vendors/irmin/test/irmin-pack/data/version_1/store.branches b/vendors/irmin/test/irmin-pack/data/version_1/store.branches new file mode 100644 index 0000000000000000000000000000000000000000..1e135f3a95a4d8a5f7d391e50fe23c917b8ba5f1 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_1/store.branches differ diff --git a/vendors/irmin/test/irmin-pack/data/version_1/store.dict b/vendors/irmin/test/irmin-pack/data/version_1/store.dict new file mode 100644 index 0000000000000000000000000000000000000000..10ff4b264c8e9fd2f5547ec1a4db97b535e0cfa3 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_1/store.dict differ diff --git a/vendors/irmin/test/irmin-pack/data/version_1/store.pack b/vendors/irmin/test/irmin-pack/data/version_1/store.pack new file mode 100644 index 0000000000000000000000000000000000000000..033f4b24a11cb8cfffe5b48792e3bacb85d992dd Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_1/store.pack differ diff --git a/vendors/irmin/test/irmin-pack/data/version_2_always/index/log b/vendors/irmin/test/irmin-pack/data/version_2_always/index/log new file mode 100644 index 0000000000000000000000000000000000000000..7fd8eefe90e8f2a1957b73d860675a0a14af1fe2 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_2_always/index/log differ diff --git a/vendors/irmin/test/irmin-pack/data/version_2_always/store.branches b/vendors/irmin/test/irmin-pack/data/version_2_always/store.branches new file mode 100644 index 0000000000000000000000000000000000000000..b35ec9eb8604d06cc073c4477be60528e1fc5a7a Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_2_always/store.branches differ diff --git a/vendors/irmin/test/irmin-pack/data/version_2_always/store.dict b/vendors/irmin/test/irmin-pack/data/version_2_always/store.dict new file mode 100644 index 0000000000000000000000000000000000000000..1cc037ce10448f42dec223530c1acc8591458689 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_2_always/store.dict differ diff --git a/vendors/irmin/test/irmin-pack/data/version_2_always/store.pack b/vendors/irmin/test/irmin-pack/data/version_2_always/store.pack new file mode 100644 index 0000000000000000000000000000000000000000..c45639fdeea1120a46b958c5fc2b9b5b773dcc7e Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_2_always/store.pack differ diff --git a/vendors/irmin/test/irmin-pack/data/version_2_minimal/index/log b/vendors/irmin/test/irmin-pack/data/version_2_minimal/index/log new file mode 100644 index 0000000000000000000000000000000000000000..e16fefc09ae7f45210a0e007ef85884a367eaa46 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_2_minimal/index/log differ diff --git a/vendors/irmin/test/irmin-pack/data/version_2_minimal/store.branches b/vendors/irmin/test/irmin-pack/data/version_2_minimal/store.branches new file mode 100644 index 0000000000000000000000000000000000000000..b35ec9eb8604d06cc073c4477be60528e1fc5a7a Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_2_minimal/store.branches differ diff --git a/vendors/irmin/test/irmin-pack/data/version_2_minimal/store.dict b/vendors/irmin/test/irmin-pack/data/version_2_minimal/store.dict new file mode 100644 index 0000000000000000000000000000000000000000..1cc037ce10448f42dec223530c1acc8591458689 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_2_minimal/store.dict differ diff --git a/vendors/irmin/test/irmin-pack/data/version_2_minimal/store.pack b/vendors/irmin/test/irmin-pack/data/version_2_minimal/store.pack new file mode 100644 index 0000000000000000000000000000000000000000..c45639fdeea1120a46b958c5fc2b9b5b773dcc7e Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_2_minimal/store.pack differ diff --git a/vendors/irmin/test/irmin-pack/data/version_3_always/index/log b/vendors/irmin/test/irmin-pack/data/version_3_always/index/log new file mode 100644 index 0000000000000000000000000000000000000000..7fd8eefe90e8f2a1957b73d860675a0a14af1fe2 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_3_always/index/log differ diff --git a/vendors/irmin/test/irmin-pack/data/version_3_always/store.0.suffix b/vendors/irmin/test/irmin-pack/data/version_3_always/store.0.suffix new file mode 100644 index 0000000000000000000000000000000000000000..9abf1552d73ff0c5df157302822efd17b8c19b97 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_3_always/store.0.suffix differ diff --git a/vendors/irmin/test/irmin-pack/data/version_3_always/store.branches b/vendors/irmin/test/irmin-pack/data/version_3_always/store.branches new file mode 100644 index 0000000000000000000000000000000000000000..b35ec9eb8604d06cc073c4477be60528e1fc5a7a Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_3_always/store.branches differ diff --git a/vendors/irmin/test/irmin-pack/data/version_3_always/store.control b/vendors/irmin/test/irmin-pack/data/version_3_always/store.control new file mode 100644 index 0000000000000000000000000000000000000000..9ee22fbad64bcdd91046576e87667df820062693 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_3_always/store.control differ diff --git a/vendors/irmin/test/irmin-pack/data/version_3_always/store.dict b/vendors/irmin/test/irmin-pack/data/version_3_always/store.dict new file mode 100644 index 0000000000000000000000000000000000000000..167a469b4f027d7e2577437c5392be4ae7e8c239 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_3_always/store.dict differ diff --git a/vendors/irmin/test/irmin-pack/data/version_3_minimal/index/log b/vendors/irmin/test/irmin-pack/data/version_3_minimal/index/log new file mode 100644 index 0000000000000000000000000000000000000000..e16fefc09ae7f45210a0e007ef85884a367eaa46 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_3_minimal/index/log differ diff --git a/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.0.suffix b/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.0.suffix new file mode 100644 index 0000000000000000000000000000000000000000..9abf1552d73ff0c5df157302822efd17b8c19b97 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.0.suffix differ diff --git a/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.branches b/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.branches new file mode 100644 index 0000000000000000000000000000000000000000..b35ec9eb8604d06cc073c4477be60528e1fc5a7a Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.branches differ diff --git a/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.control b/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.control new file mode 100644 index 0000000000000000000000000000000000000000..0dc97c18fc3703afc6cb7f1d5633cc44ae47e236 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.control differ diff --git a/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.dict b/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.dict new file mode 100644 index 0000000000000000000000000000000000000000..167a469b4f027d7e2577437c5392be4ae7e8c239 Binary files /dev/null and b/vendors/irmin/test/irmin-pack/data/version_3_minimal/store.dict differ diff --git a/vendors/irmin/test/irmin-pack/dune b/vendors/irmin/test/irmin-pack/dune new file mode 100644 index 0000000000000000000000000000000000000000..bb1cd06fbfa1f3080b0cbc80bcd1581a30949593 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/dune @@ -0,0 +1,62 @@ +(library + (name test_pack) + (modules + test_pack + multiple_instances + test_existing_stores + test_inode + test_tree + test_hashes + import + test_pack_version_bump + test_snapshot + test_upgrade + test_gc + test_flush_reload) + (libraries + alcotest + fmt + common + index + irmin + irmin-test + irmin-pack + irmin-pack.mem + irmin-tezos + logs + lwt + lwt.unix + fpath + hex) + (preprocess + (pps ppx_irmin.internal))) + +(executable + (name test) + (modules test) + (libraries irmin irmin-test test_pack)) + +(rule + (alias runtest) + ;; Attached to `irmin-tezos` to avoid a cyclic dependency with `irmin-pack` + (package irmin-tezos) + (action + (run ./test.exe -q --color=always))) + +(library + (name common) + (modules common) + (libraries + alcotest + index + irmin + irmin-test + irmin-pack + irmin-pack.unix + irmin-tezos + logs + lwt + hex + fpath) + (preprocess + (pps ppx_irmin.internal))) diff --git a/vendors/irmin/test/irmin-pack/import.ml b/vendors/irmin/test/irmin-pack/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..e6f13c7c212906baeff59aa7fa93a8f180d08c5f --- /dev/null +++ b/vendors/irmin/test/irmin-pack/import.ml @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Irmin.Export_for_backends diff --git a/vendors/irmin/test/irmin-pack/multiple_instances.ml b/vendors/irmin/test/irmin-pack/multiple_instances.ml new file mode 100644 index 0000000000000000000000000000000000000000..93f9904a20c517b9aaafcb631c3f63db3c11a475 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/multiple_instances.ml @@ -0,0 +1,114 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +let root = Filename.concat "_build" "test-instances" +let src = Logs.Src.create "tests.instances" ~doc:"Tests" + +module Log = (val Logs.src_log src : Logs.LOG) + +let index_log_size = Some 1_000 + +module S = struct + module Maker = Irmin_pack_unix.Maker (Conf) + include Maker.Make (Schema) +end + +let config ?(readonly = false) ?(fresh = true) root = + Irmin_pack.config ~readonly ?index_log_size ~fresh root + +let info () = S.Info.empty + +let open_ro_after_rw_closed () = + rm_dir root; + let* rw = S.Repo.v (config ~readonly:false ~fresh:true root) in + let* t = S.main rw in + let tree = S.Tree.singleton [ "a" ] "x" in + S.set_tree_exn ~parents:[] ~info t [] tree >>= fun () -> + let* ro = S.Repo.v (config ~readonly:true ~fresh:false root) in + S.Repo.close rw >>= fun () -> + let* t = S.main ro in + let* c = S.Head.get t in + S.Commit.of_hash ro (S.Commit.hash c) >>= function + | None -> Alcotest.fail "no hash" + | Some commit -> + let tree = S.Commit.tree commit in + let* x = S.Tree.find tree [ "a" ] in + Alcotest.(check (option string)) "RO find" (Some "x") x; + S.Repo.close ro + +let check_binding ?msg repo commit key value = + let msg = + match msg with + | Some m -> m + | None -> + Fmt.str "Expected binding [%a ↦ %s]" Fmt.(Dump.list string) key value + in + S.Commit.of_hash repo (S.Commit.hash commit) >>= function + | None -> Alcotest.failf "commit not found" + | Some commit -> + let tree = S.Commit.tree commit in + let+ x = S.Tree.find tree key in + Alcotest.(check (option string)) msg (Some value) x + +let ro_reload_after_add () = + let check ro c k v = + S.Commit.of_hash ro (S.Commit.hash c) >>= function + | None -> Alcotest.failf "commit not found" + | Some commit -> + let tree = S.Commit.tree commit in + let+ x = S.Tree.find tree [ k ] in + Alcotest.(check (option string)) "RO find" (Some v) x + in + rm_dir root; + let* rw = S.Repo.v (config ~readonly:false ~fresh:true root) in + let* ro = S.Repo.v (config ~readonly:true ~fresh:false root) in + let tree = S.Tree.singleton [ "a" ] "x" in + let* c1 = S.Commit.v rw ~parents:[] ~info:(info ()) tree in + S.reload ro; + check ro c1 "a" "x" >>= fun () -> + let tree = S.Tree.singleton [ "a" ] "y" in + let* c2 = S.Commit.v rw ~parents:[] ~info:(info ()) tree in + check ro c1 "a" "x" >>= fun () -> + let* () = + S.Commit.of_hash ro (S.Commit.hash c2) >|= function + | None -> () + | Some _ -> Alcotest.failf "should not find branch by" + in + S.reload ro; + check ro c2 "a" "y" >>= fun () -> + S.Repo.close ro >>= fun () -> S.Repo.close rw + +let ro_reload_after_close () = + let binding f = f [ "a" ] "x" in + rm_dir root; + let* rw = S.Repo.v (config ~readonly:false ~fresh:true root) in + let* ro = S.Repo.v (config ~readonly:true ~fresh:false root) in + let tree = binding (S.Tree.singleton ?metadata:None) in + let* c1 = S.Commit.v rw ~parents:[] ~info:(info ()) tree in + S.Repo.close rw >>= fun () -> + S.reload ro; + binding (check_binding ro c1) >>= fun () -> S.Repo.close ro + +let tests = + let tc name test = Alcotest_lwt.test_case name `Quick (fun _switch -> test) in + [ + tc "Test open ro after rw closed" open_ro_after_rw_closed; + tc "Test ro reload after add" ro_reload_after_add; + tc "Test ro reload after close" ro_reload_after_close; + ] diff --git a/vendors/irmin/test/irmin-pack/multiple_instances.mli b/vendors/irmin/test/irmin-pack/multiple_instances.mli new file mode 100644 index 0000000000000000000000000000000000000000..4acc26805b83290745657bafd214fc23476222e8 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/multiple_instances.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val tests : unit Alcotest_lwt.test_case list diff --git a/vendors/irmin/test/irmin-pack/test.ml b/vendors/irmin/test/irmin-pack/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..8b35dbfa8f7b4ffadce36766d7d5a08d58b75d24 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test.ml @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let () = + Lwt_main.run + @@ Irmin_test.Store.run "irmin-pack" ~misc:Test_pack.misc + ~sleep:Lwt_unix.sleep + (List.map (fun s -> (`Quick, s)) Test_pack.suite) diff --git a/vendors/irmin/test/irmin-pack/test.mli b/vendors/irmin/test/irmin-pack/test.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin-pack/test_existing_stores.ml b/vendors/irmin/test/irmin-pack/test_existing_stores.ml new file mode 100644 index 0000000000000000000000000000000000000000..aaacec297769617ff36eb22d937831391a1685e2 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_existing_stores.ml @@ -0,0 +1,225 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +let src = Logs.Src.create "tests.integrity_checks" ~doc:"Test integrity checks" + +module Log = (val Logs.src_log src : Logs.LOG) + +let config ?(readonly = false) ?(fresh = true) root = + Irmin_pack.config ~readonly ~index_log_size:1000 ~fresh root + +let archive = + [ + ("bar", [ ([ "a"; "d" ], "x"); ([ "a"; "b"; "c" ], "z") ]); + ("foo", [ ([ "b" ], "y") ]); + ] + +let root_v1_archive, root_v1, tmp = + let open Fpath in + ( v "test" / "irmin-pack" / "data" / "version_1" |> to_string, + v "_build" / "test_pack_version_1" |> to_string, + v "_build" / "test_index_reconstruct" |> to_string ) + +module Test (S : Irmin.Generic_key.KV with type Schema.Contents.t = string) = +struct + let check_commit repo commit bindings = + commit |> S.Commit.key |> S.Commit.of_key repo >>= function + | None -> + Alcotest.failf "Commit `%a' is dangling in repo" S.Commit.pp_hash commit + | Some commit -> + let tree = S.Commit.tree commit in + bindings + |> Lwt_list.iter_s (fun (key, value) -> + S.Tree.find tree key + >|= Alcotest.(check (option string)) + (Fmt.str "Expected binding [%a ↦ %s]" + Fmt.(Dump.list string) + key value) + (Some value)) + + let check_repo repo structure = + structure + |> Lwt_list.iter_s @@ fun (branch, bindings) -> + S.Branch.find repo branch >>= function + | None -> Alcotest.failf "Couldn't find expected branch `%s'" branch + | Some commit -> check_commit repo commit bindings +end + +module Small_conf = struct + let entries = 2 + let stable_hash = 3 + let contents_length_header = Some `Varint + let inode_child_order = `Hash_bits + let forbid_empty_dir_persistence = false +end + +module V1_maker = Irmin_pack_unix.Maker (Small_conf) +module V2_maker = Irmin_pack_unix.Maker (Conf) + +module Schema_v2 = struct + open Irmin + module Metadata = Metadata.None + module Contents = Contents.String_v2 + module Path = Path.String_list + module Branch = Branch.String + module Hash = Hash.SHA1 + module Node = Node.Generic_key.Make_v2 (Hash) (Path) (Metadata) + module Commit = Commit.Generic_key.Make_v2 (Hash) + module Info = Info.Default +end + +module V1 () = V1_maker.Make (Schema_v2) +module V2 () = V2_maker.Make (Schema_v2) + +module Test_store = struct + module S = V2 () + include Test (S) +end + +module Test_reconstruct = struct + module S = V2 () + include Test (S) + + let setup_test_env () = + setup_test_env ~root_archive:root_v1_archive ~root_local_build:root_v1; + rm_dir tmp; + let cmd = + Filename.quote_command "cp" [ "-R"; "-p"; root_v1_archive; tmp ] + in + exec_cmd cmd |> function + | Ok () -> () + | Error n -> + Fmt.failwith + "Failed to set up the test environment: command `%s' exited with \ + non-zero exit code %d" + cmd n + + let test_reconstruct () = + let module Kind = Irmin_pack.Pack_value.Kind in + setup_test_env (); + let conf = config ~readonly:false ~fresh:false root_v1 in + (* Open store in RW to migrate it to V3. *) + let* repo = S.Repo.v conf in + let* () = S.Repo.close repo in + (* Test on a V3 store. *) + S.test_traverse_pack_file (`Reconstruct_index `In_place) conf; + let index_old = + Index.v_exn ~fresh:false ~readonly:false ~log_size:500_000 tmp + in + let index_new = + Index.v_exn ~fresh:false ~readonly:false ~log_size:500_000 root_v1 + in + Index.iter + (fun k (offset, length, kind) -> + [%log.debug + "index find k = %a (off, len, kind) = (%a, %d, %a)" + (Irmin.Type.pp S.Hash.t) k Int63.pp offset length Kind.pp kind]; + match Index.find index_new k with + | Some (offset', length', kind') -> + Alcotest.(check int63) "check offset" offset offset'; + Alcotest.(check int) "check length" length length'; + Alcotest.(check_repr Kind.t) "check kind" kind kind' + | None -> + Alcotest.failf "expected to find hash %a" (Irmin.Type.pp S.Hash.t) k) + index_old; + Index.close_exn index_old; + Index.close_exn index_new; + [%log.app + "Checking old bindings are still reachable post index reconstruction)"]; + let* r = S.Repo.v conf in + check_repo r archive >>= fun () -> S.Repo.close r +end + +module Test_corrupted_stores = struct + let root_archive, root = + let open Fpath in + ( v "test" / "irmin-pack" / "data" / "corrupted" |> to_string, + v "_build" / "test_integrity" |> to_string ) + + let setup_test_env () = setup_test_env ~root_archive ~root_local_build:root + + let test () = + setup_test_env (); + let module S = V2 () in + let* rw = S.Repo.v (config ~fresh:false root) in + [%log.app + "integrity check on a store where 3 entries are missing from pack"]; + (match S.integrity_check ~auto_repair:false rw with + | Ok `No_error -> Alcotest.fail "Store is corrupted, the check should fail" + | Error (`Corrupted 3) -> () + | _ -> Alcotest.fail "With auto_repair:false should not match"); + (match S.integrity_check ~auto_repair:true rw with + | Ok (`Fixed 3) -> () + | _ -> Alcotest.fail "Integrity check should repair the store"); + (match S.integrity_check ~auto_repair:false rw with + | Ok `No_error -> () + | _ -> Alcotest.fail "Store is repaired, should return Ok"); + S.Repo.close rw +end + +module Test_corrupted_inode = struct + let root_archive, root = + let open Fpath in + ( v "test" / "irmin-pack" / "data" / "corrupted_inode" |> to_string, + v "_build" / "test_integrity_inode" |> to_string ) + + let setup_test_env () = setup_test_env ~root_archive ~root_local_build:root + + let test () = + setup_test_env (); + let module S = V1 () in + let* rw = S.Repo.v (config ~fresh:false root) in + let get_head c = + match Irmin.Type.of_string S.Hash.t c with + | Ok x -> ( + let* commit = S.Commit.of_hash rw x in + match commit with + | None -> Alcotest.fail "could not find commit in store" + | Some x -> Lwt.return [ x ]) + | _ -> Alcotest.fail "could not read hash" + in + [%log.app "integrity check of inodes on a store with one corrupted inode"]; + let c2 = "8d89b97726d9fb650d088cb7e21b78d84d132c6e" in + let* heads = get_head c2 in + let* result = S.integrity_check_inodes ~heads rw in + (match result with + | Ok _ -> + Alcotest.failf + "Store is corrupted for second commit, the check should fail" + | Error _ -> ()); + let c1 = "1b1e259ca4e7bb8dc32c73ade93d8181c29cebe6" in + let* heads = get_head c1 in + let* result = S.integrity_check_inodes ~heads rw in + (match result with + | Error _ -> + Alcotest.fail + "Store is not corrupted for first commit, the check should not fail." + | Ok _ -> ()); + S.Repo.close rw +end + +let tests = + [ + Alcotest_lwt.test_case "Test index reconstruction" `Quick (fun _switch -> + Test_reconstruct.test_reconstruct); + Alcotest_lwt.test_case "Test integrity check" `Quick (fun _switch -> + Test_corrupted_stores.test); + Alcotest_lwt.test_case "Test integrity check for inodes" `Quick + (fun _switch -> Test_corrupted_inode.test); + ] diff --git a/vendors/irmin/test/irmin-pack/test_existing_stores.mli b/vendors/irmin/test/irmin-pack/test_existing_stores.mli new file mode 100644 index 0000000000000000000000000000000000000000..4acc26805b83290745657bafd214fc23476222e8 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_existing_stores.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val tests : unit Alcotest_lwt.test_case list diff --git a/vendors/irmin/test/irmin-pack/test_flush_reload.ml b/vendors/irmin/test/irmin-pack/test_flush_reload.ml new file mode 100644 index 0000000000000000000000000000000000000000..31e4db635148d6214ea81bb4cb4425e47f6d98b0 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_flush_reload.ml @@ -0,0 +1,254 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common +open Test_upgrade + +let suffix_mem repo e = + let k = key_of_entry e in + try + match e.k with + | `c -> + Store.S.X.Commit.CA.unsafe_find ~check_integrity:false + (snd (Store.S.X.Repo.commit_t repo)) + k + |> Option.is_some + | `n -> + Store.S.X.Node.CA.unsafe_find ~check_integrity:false + (snd (Store.S.X.Repo.node_t repo)) + k + |> Option.is_some + | `b -> + Store.S.X.Contents.CA.unsafe_find ~check_integrity:false + (Store.S.X.Repo.contents_t repo) + k + |> Option.is_some + with Irmin_pack_unix.Pack_store.Invalid_read _ -> + (* In RW mode, [mem] will raise an exception if the offset of the key is + out of the bounds of the pack file *) + false + +let check_suffix repo model = + List.iter + (fun e -> + let got = suffix_mem repo e in + let exp = Hashtbl.mem model.Model.suffix e.o in + match (got, exp) with + | false, false -> () + | true, true -> () + | true, false -> + Alcotest.failf "Pack entry with hash:%a off:%d shouldn't be there" + pp_hash e.h (Int63.to_int e.o) + | false, true -> + Alcotest.failf "Pack entry with hash:%a off:%d is missing" pp_hash e.h + (Int63.to_int e.o)) + pack_entries + +let check_ro t = + match t.ro with + | None -> assert false + | Some (model, repo) -> + check_dict repo model; + check_index repo model; + check_suffix repo model + +type phase_flush = + | S1_before_flush + | S2_after_flush_dict + | S3_after_flush_suffix + | S4_after_flush +[@@deriving irmin ~pp] + +let write1_dict model = + Model.preload_dict model; + Model.write1_dict model + +let write1_suffix model = + write1_dict model; + Model.preload_suffix model; + Model.write1_suffix model + +let write1_index model = + write1_suffix model; + Model.preload_index model; + Model.write1_index model + +let reload_ro t current_phase = + [%logs.app + "*** reload_ro %a, %a" pp_setup t.setup pp_phase_flush current_phase]; + match t.ro with + | None -> assert false + | Some (model, repo) -> + let () = + match current_phase with + | S1_before_flush -> () + | S2_after_flush_dict -> write1_dict model + | S3_after_flush_suffix -> write1_suffix model + | S4_after_flush -> write1_index model + in + Store.reload repo + +let write1_no_flush bstore nstore cstore = + let* _ = Store.put_borphan bstore in + let* _ = Store.put_c0 bstore nstore cstore in + let* _ = Store.put_c1 bstore nstore cstore in + let* _ = Store.put_borphan' bstore in + Lwt.return_unit + +(* These tests always open both RW and RO without any data in the model. *) +let start t = + let* () = start_rw t in + let* () = open_ro t S2_before_write in + let rw = Option.get t.rw |> snd in + let ro = Option.get t.ro |> snd in + Lwt.return (rw, ro) + +(* Open both stores. RW writes but does not flush - we do this by running the + rest of the test inside the [batch]. Then reload the RO at different phases + during the flush. *) +let test_one t ~(ro_reload_at : phase_flush) = + let aux phase = + let () = check_ro t in + if ro_reload_at = phase then reload_ro t phase; + check_ro t + in + let* rw, _ = start t in + let* () = + Store.S.Backend.Repo.batch rw (fun bstore nstore cstore -> + let* () = write1_no_flush bstore nstore cstore in + let () = aux S1_before_flush in + let hook = function + | `After_dict -> aux S2_after_flush_dict + | `After_suffix -> aux S3_after_flush_suffix + in + let () = Store.S.X.Repo.flush_with_hook ~hook rw in + let () = aux S4_after_flush in + Lwt.return_unit) + in + Lwt.return_unit + +let test_one_guarded setup ~ro_reload_at = + let t = create_test_env setup in + let* () = test_one t ~ro_reload_at in + close_everything t + +let setup = + (* We are using indexing strategy always here to have more entries in index + for the flush/reload tests. *) + { start_mode = From_scratch; indexing_strategy = `always; lru_size = 0 } + +let test_flush () = + let t = test_one_guarded setup in + let* () = t ~ro_reload_at:S1_before_flush in + let* () = t ~ro_reload_at:S2_after_flush_dict in + let* () = t ~ro_reload_at:S3_after_flush_suffix in + let* () = t ~ro_reload_at:S4_after_flush in + Lwt.return_unit + +type phase_reload = + | S1_before_reload + | S2_after_reload_index + | S3_after_reload_control + | S4_after_reload_suffix + | S5_after_reload +[@@deriving irmin ~pp] + +let write1_index model = + Model.preload_index model; + Model.write1_index model + +let write1_suffix model = + Model.preload_suffix model; + Model.write1_suffix model + +let write1_dict model = + Model.preload_dict model; + Model.write1_dict model + +let write_all model = + write1_index model; + write1_suffix model; + write1_dict model + +let flush_rw t (current_phase : phase_reload) = + [%logs.app + "*** flush_rw %a, %a" pp_setup t.setup pp_phase_reload current_phase]; + let () = + match t.ro with + | None -> assert false + | Some (model, _) -> ( + match current_phase with + | S1_before_reload -> write_all model + | S2_after_reload_index -> + write1_dict model; + write1_suffix model + | S3_after_reload_control | S4_after_reload_suffix | S5_after_reload -> + (* If the control has not changed, suffix and dict are not reloaded. *) + ()) + in + match t.rw with None -> assert false | Some (_, repo) -> Store.S.flush repo + +let check_ro t = + match t.ro with + | None -> assert false + | Some (model, repo) -> + check_dict repo model; + check_index repo model; + check_suffix repo model + +let test_one t ~(rw_flush_at : phase_reload) = + let aux phase = if rw_flush_at = phase then flush_rw t phase in + let* rw, ro = start t in + let reload_ro () = + Store.S.Backend.Repo.batch rw (fun bstore nstore cstore -> + let* () = write1_no_flush bstore nstore cstore in + let () = aux S1_before_reload in + let hook = function + | `After_index -> aux S2_after_reload_index + | `After_control -> aux S3_after_reload_control + | `After_suffix -> aux S4_after_reload_suffix + in + let () = Store.S.X.Repo.reload_with_hook ~hook ro in + let () = aux S5_after_reload in + Lwt.return_unit) + in + let () = check_ro t in + let* () = reload_ro () in + let () = check_ro t in + Lwt.return_unit + +let test_one_guarded setup ~rw_flush_at = + let t = create_test_env setup in + let* () = test_one t ~rw_flush_at in + close_everything t + +let test_reload () = + let t = test_one_guarded setup in + let* () = t ~rw_flush_at:S1_before_reload in + let* () = t ~rw_flush_at:S2_after_reload_index in + let* () = t ~rw_flush_at:S3_after_reload_control in + let* () = t ~rw_flush_at:S4_after_reload_suffix in + let* () = t ~rw_flush_at:S5_after_reload in + Lwt.return_unit + +let tests = + [ + Alcotest_lwt.test_case "Reload during flush stages" `Quick + (fun _switch () -> test_flush ()); + Alcotest_lwt.test_case "Flush during reload stages" `Quick + (fun _switch () -> test_reload ()); + ] diff --git a/vendors/irmin/test/irmin-pack/test_gc.ml b/vendors/irmin/test/irmin-pack/test_gc.ml new file mode 100644 index 0000000000000000000000000000000000000000..ae85ca34afec11fba4451dd38ae9091fe33da4dc --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_gc.ml @@ -0,0 +1,788 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +let src = Logs.Src.create "tests.gc" ~doc:"Test gc" + +module Log = (val Logs.src_log src : Logs.LOG) + +let test_dir = "_build" + +let fresh_name = + let c = ref 0 in + fun () -> + incr c; + let name = Filename.concat test_dir ("test-gc" ^ string_of_int !c) in + name + +let tc name f = Alcotest_lwt.test_case name `Quick (fun _switch () -> f ()) + +include struct + module S = struct + module Maker = Irmin_pack_unix.Maker (Conf) + include Maker.Make (Schema) + end + + type t = { + root : string; + repo : S.Repo.t; + parents : S.Commit.t list; + tree : S.tree; + } + + let config ~lru_size ~readonly ~fresh root = + Irmin_pack.config ~readonly + ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal ~fresh ~lru_size + root + + let info = S.Info.empty + + let start_gc ?(throttle = `Block) t commit = + let commit_key = S.Commit.key commit in + let* launched = S.start_gc ~unlink:false ~throttle t.repo commit_key in + (match (throttle, launched) with + | `Block, true | `Skip, false -> () + | _ -> Alcotest.failf "start_gc returned unexpected result %b" launched); + Lwt.return_unit + + let finalise_gc t = + let* wait = S.finalise_gc ~wait:true t.repo in + assert wait; + Lwt.return_unit + + let commit t = + let parents = List.map S.Commit.key t.parents in + let+ h = S.Commit.v t.repo ~info ~parents t.tree in + S.Tree.clear t.tree; + h + + let set t key data = + let* tree = S.Tree.add t.tree key data in + Lwt.return { t with tree } + + let del t key = + let* tree = S.Tree.remove t.tree key in + Lwt.return { t with tree } + + let checkout t key = + let* c = S.Commit.of_hash t.repo (S.Commit.hash key) in + match c with + | None -> Lwt.return_none + | Some commit -> + let tree = S.Commit.tree commit in + Lwt.return_some { t with tree; parents = [ commit ] } + + let checkout_exn t key = + let* o = checkout t key in + match o with None -> Lwt.fail Not_found | Some p -> Lwt.return p + + let init ?(lru_size = 0) ?(readonly = false) ?(fresh = true) ?root () = + (* start with a clean dir if fresh *) + let root = Option.value root ~default:(fresh_name ()) in + if fresh then rm_dir root; + let+ repo = S.Repo.v (config ~readonly ~fresh ~lru_size root) in + let tree = S.Tree.empty () in + { root; repo; tree; parents = [] } +end + +(** Predefined commits. *) +let commit_1 t = + let* t = set t [ "a"; "b" ] "Novembre" in + let* t = set t [ "a"; "c" ] "Juin" in + let+ h = commit t in + (t, h) + +let commit_2 t = + let* t = set t [ "a"; "d" ] "Mars" in + let+ h = commit t in + (t, h) + +let commit_3 t = + let* t = set t [ "a"; "f" ] "Fevrier" in + let+ h = commit t in + (t, h) + +let commit_4 t = + let* t = set t [ "a"; "e" ] "Mars" in + let+ h = commit t in + (t, h) + +let commit_5 t = + let* t = set t [ "e"; "a" ] "Avril" in + let+ h = commit t in + (t, h) + +let commit_del t = + let* t = del t [ "a"; "c" ] in + let+ h = commit t in + (t, h) + +(** Wrappers for testing. *) +let check_blob tree key expected = + let+ got = S.Tree.find tree key in + Alcotest.(check (option string)) "find blob" (Some expected) got + +let check_none tree key = + let+ got = S.Tree.find tree key in + Alcotest.(check (option string)) "blob not found" None got + +let check_tree_1 tree = + let* () = check_blob tree [ "a"; "b" ] "Novembre" in + check_blob tree [ "a"; "c" ] "Juin" + +let check_1 t c = + S.Commit.of_key t.repo (S.Commit.key c) >>= function + | None -> Alcotest.fail "no hash found in repo" + | Some commit -> + let tree = S.Commit.tree commit in + check_tree_1 tree + +let check_2 t c = + S.Commit.of_key t.repo (S.Commit.key c) >>= function + | None -> Alcotest.fail "no hash found in repo" + | Some commit -> + let tree = S.Commit.tree commit in + let* () = check_blob tree [ "a"; "d" ] "Mars" in + (* c2 always contains c1 tree in tests *) + check_tree_1 tree + +let check_3 t c = + S.Commit.of_key t.repo (S.Commit.key c) >>= function + | None -> Alcotest.fail "no hash found in repo" + | Some commit -> + let tree = S.Commit.tree commit in + check_blob tree [ "a"; "f" ] "Fevrier" + +let check_4 t c = + S.Commit.of_key t.repo (S.Commit.key c) >>= function + | None -> Alcotest.fail "no hash found in repo" + | Some commit -> + let tree = S.Commit.tree commit in + check_blob tree [ "a"; "e" ] "Mars" + +let check_5 t c = + S.Commit.of_key t.repo (S.Commit.key c) >>= function + | None -> Alcotest.fail "no hash found in repo" + | Some commit -> + let tree = S.Commit.tree commit in + let* () = check_blob tree [ "e"; "a" ] "Avril" in + (* c5 always contains c1 and c4 trees in tests *) + let* () = check_tree_1 tree in + check_blob tree [ "a"; "e" ] "Mars" + +let check_del_1 t c = + S.Commit.of_key t.repo (S.Commit.key c) >>= function + | None -> Alcotest.fail "no hash found in repo" + | Some commit -> + let tree = S.Commit.tree commit in + check_none tree [ "a"; "c" ] + +let check_not_found t key msg = + let* c = S.Commit.of_hash t.repo (S.Commit.hash key) in + match c with + | None -> Lwt.return_unit + | Some _ -> Alcotest.failf "should not find %s" msg + +module Blocking_gc = struct + (** Check that gc preserves and deletes commits accordingly. *) + let one_gc () = + (* c1 - c2 *) + (* \---- c3 *) + (* gc(c3) *) + let* t = init () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* t = checkout_exn t c1 in + let* t, c3 = commit_3 t in + [%log.debug "Gc c1, c2, keep c3"]; + let* () = start_gc t c3 in + let* () = finalise_gc t in + let* () = check_not_found t c1 "removed c1" in + let* () = check_not_found t c2 "removed c2" in + let* () = check_3 t c3 in + S.Repo.close t.repo + + (** Check that calling gc twice works. *) + let two_gc () = + (* gc(c4) gc(c5) *) + (* c1 - c2 --- c4 -------- c5 *) + (* \---- c3 *) + let* t = init () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* t = checkout_exn t c1 in + let* t, c3 = commit_3 t in + let* t = checkout_exn t c2 in + let* t, c4 = commit_4 t in + [%log.debug "Gc c1, c2, c3, keep c4"]; + let* () = start_gc t c4 in + let* () = finalise_gc t in + let* t = checkout_exn t c4 in + let* t, c5 = commit_5 t in + let* () = check_5 t c5 in + [%log.debug "Gc c4, keep c5"]; + let* () = start_gc t c5 in + let* () = finalise_gc t in + let* () = check_5 t c5 in + let* () = check_not_found t c1 "removed c1" in + let* () = check_not_found t c2 "removed c2" in + let* () = check_not_found t c3 "removed c3" in + let* () = check_not_found t c4 "removed c4" in + S.Repo.close t.repo + + (** Check that calling gc on first commit of chain keeps everything. *) + let gc_keeps_all () = + (* c1 - c2 - c3 *) + (* gc(c1) *) + let* t = init () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* t = checkout_exn t c2 in + let* t, c3 = commit_3 t in + [%log.debug "Keep c1, c2, c3"]; + let* () = start_gc t c1 in + let* () = finalise_gc t in + let* () = check_1 t c1 in + let* () = check_2 t c2 in + let* () = check_3 t c3 in + S.Repo.close t.repo + + (** Check that adding back gced commits works. *) + let gc_add_back () = + (* c1 - c_del - c3 ------ c1 - c2 ------- c3 *) + (* gc(c3) gc(c1) *) + let* t = init () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c_del = commit_del t in + let* t = checkout_exn t c_del in + let* t, c3 = commit_3 t in + [%log.debug "Gc c1, c_del, keep c3"]; + let* () = start_gc t c3 in + let* () = finalise_gc t in + let* () = check_not_found t c1 "removed c1" in + let* () = check_not_found t c_del "removed c_del" in + let* () = check_3 t c3 in + let* () = check_del_1 t c3 in + [%log.debug "Add back c1"]; + let* t = checkout_exn t c3 in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* () = check_1 t c1 in + let* t, c2 = commit_2 t in + let* () = check_2 t c2 in + [%log.debug "Gc c3, keep c1, c2"]; + let* () = start_gc t c1 in + let* () = finalise_gc t in + let* () = check_not_found t c3 "removed c3" in + let* () = check_2 t c2 in + [%log.debug "Add back c3"]; + let* t = checkout_exn t c2 in + let* t, c3 = commit_3 t in + let* () = check_3 t c2 in + let* () = check_3 t c3 in + S.Repo.close t.repo + + (** Check that gc and close work together. *) + let close () = + (* c1 ------ c2 *) + (* gc(c1) gc(c2) *) + (* close close close *) + let* t = init () in + let store_name = t.root in + let* t, c1 = commit_1 t in + let* () = start_gc t c1 in + let* () = finalise_gc t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* () = S.Repo.close t.repo in + let* t = init ~readonly:false ~fresh:false ~root:store_name () in + let* () = check_1 t c1 in + let* () = check_2 t c2 in + let* () = S.Repo.close t.repo in + let* t = init ~readonly:false ~fresh:false ~root:store_name () in + [%log.debug "Gc c1, keep c2"]; + let* () = start_gc t c2 in + let* () = finalise_gc t in + let* () = S.Repo.close t.repo in + let* t = init ~readonly:false ~fresh:false ~root:store_name () in + let* () = check_not_found t c1 "removed c1" in + let* () = check_2 t c2 in + S.Repo.close t.repo + + (** Check that gc works on a commit with two parents. *) + let gc_commit_with_two_parents () = + (* gc(c3) *) + (* c1 - c3 *) + (* c2 -/ *) + let* t = init () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let t = { t with parents = [ c1; c2 ] } in + let* t, c3 = commit_3 t in + let* () = start_gc t c3 in + let* () = finalise_gc t in + let* () = check_not_found t c1 "removed c1" in + let* () = check_not_found t c2 "removed c2" in + let* () = check_3 t c3 in + S.Repo.close t.repo + + (** Check that gc preserves and deletes commits from RO. *) + let gc_ro () = + (* c1 ---- c3 ------------------- c4 - c5 *) + (* \- c2 *) + (* gc(c3) gc(c4) *) + (* reload reload reload reload *) + let* t = init () in + let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* t = checkout_exn t c1 in + let* t, c3 = commit_3 t in + S.reload ro_t.repo; + [%log.debug "Gc c1, c2, keeps c3"]; + let* () = start_gc t c3 in + let* () = finalise_gc t in + [%log.debug "RO finds everything before reload"]; + let* () = check_1 ro_t c1 in + let* () = check_2 ro_t c2 in + let* () = check_3 ro_t c3 in + S.reload ro_t.repo; + [%log.debug "RO does not find gced commits after reload"]; + let* () = check_3 ro_t c3 in + let* () = check_not_found ro_t c1 "c1" in + let* () = check_not_found ro_t c2 "c2" in + let* t = checkout_exn t c3 in + let* t, c4 = commit_4 t in + let* t = checkout_exn t c4 in + let* t, c5 = commit_5 t in + S.reload ro_t.repo; + [%log.debug "Gc c3, keep c4, c5"]; + let* () = start_gc t c4 in + let* () = finalise_gc t in + [%log.debug "RO finds c3, c4, c5 before reload"]; + let* () = check_3 ro_t c3 in + let* () = check_4 ro_t c4 in + let* () = check_5 ro_t c5 in + S.reload ro_t.repo; + [%log.debug "RO finds c4, c5 but not c3 after reload"]; + let* () = check_4 ro_t c4 in + let* () = check_5 ro_t c5 in + let* () = check_not_found ro_t c3 "c3" in + let* () = S.Repo.close t.repo in + S.Repo.close ro_t.repo + + (** Check that RO works if reload is called after two gcs. *) + let ro_after_two_gc () = + (* c1 ------- c2 *) + (* gc(c1) gc(c2) *) + (* reload *) + let* t = init () in + let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let* t, c1 = commit_1 t in + S.reload ro_t.repo; + let* () = start_gc t c1 in + let* () = finalise_gc t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* () = start_gc t c2 in + let* () = finalise_gc t in + [%log.debug "RO finds c1, but not c2 before reload"]; + let* () = check_1 ro_t c1 in + let* () = check_not_found ro_t c2 "c2" in + [%log.debug "RO finds c2, but not c1 after reload"]; + S.reload ro_t.repo; + let* () = check_2 ro_t c2 in + let* () = check_not_found ro_t c1 "c1" in + let* () = S.Repo.close t.repo in + S.Repo.close ro_t.repo + + (** Check that gc and close and ro work together. *) + let ro_close () = + let* t = init () in + let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* () = S.Repo.close ro_t.repo in + let* () = start_gc t c2 in + let* () = finalise_gc t in + [%log.debug "RO reopens is similar to a reload"]; + let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let* () = check_2 ro_t c2 in + let* () = check_not_found ro_t c1 "removed c1" in + let* t = checkout_exn t c2 in + let* t, c3 = commit_3 t in + S.reload ro_t.repo; + let* () = check_3 t c3 in + let* () = check_3 ro_t c3 in + let* () = check_not_found ro_t c1 "removed c1" in + let* () = S.Repo.close t.repo in + S.Repo.close ro_t.repo + + (** Check opening RO store and calling reload right after. *) + let ro_reload_after_v () = + let* t = init () in + let* t, c1 = commit_1 t in + let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + S.reload ro_t.repo; + let* () = check_1 ro_t c1 in + let* () = S.Repo.close t.repo in + S.Repo.close ro_t.repo + + (** Check that gc works when the lru caches some objects that are delete by + consequent commits. See https://github.com/mirage/irmin/issues/1920. *) + let gc_lru () = + let check t c = + S.Commit.of_key t.repo (S.Commit.key c) >>= function + | None -> Alcotest.fail "no hash found in repo" + | Some commit -> + let tree = S.Commit.tree commit in + check_blob tree [ "a"; "b"; "c" ] "b" + in + let* t = init ~lru_size:100 () in + let* t = set t [ "a"; "b"; "c" ] "b" in + let* c1 = commit t in + let* t = checkout_exn t c1 in + let* t = set t [ "a"; "d"; "c" ] "b" in + let* c2 = commit t in + let* t = checkout_exn t c2 in + let* t = del t [ "a"; "d"; "c" ] in + let* c3 = commit t in + let* t = checkout_exn t c3 in + let* t = set t [ "a"; "b"; "e" ] "a" in + let* c4 = commit t in + let* () = start_gc t c3 in + let* () = finalise_gc t in + let* () = check t c4 in + S.Repo.close t.repo + + (** Check that calling gc during a batch raises an error. *) + let gc_during_batch () = + let* t = init () in + let* t, c1 = commit_1 t in + let* _ = + Alcotest.check_raises_lwt "Should not call gc in batch" + (Irmin_pack_unix.Errors.Pack_error `Gc_forbidden_during_batch) + (fun () -> + S.Backend.Repo.batch t.repo (fun _ _ _ -> + let* () = start_gc t c1 in + finalise_gc t)) + in + S.Repo.close t.repo + + let tests = + [ + tc "Test one gc" one_gc; + tc "Test twice gc" two_gc; + tc "Test gc keeps commits" gc_keeps_all; + tc "Test adding back commits" gc_add_back; + tc "Test close" close; + tc "Test gc commit with two parents" gc_commit_with_two_parents; + tc "Test gc ro" gc_ro; + tc "Test reload after two gc" ro_after_two_gc; + tc "Test ro close" ro_close; + tc "Test ro reload after open" ro_reload_after_v; + tc "Test lru" gc_lru; + tc "Test gc during batch" gc_during_batch; + ] +end + +module Concurrent_gc = struct + (** Check that finding old objects during a gc works. *) + let find_during_gc ~lru_size () = + let* t = init ~lru_size () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + [%log.debug "Gc c1 keep c2"]; + let* () = start_gc t c2 in + let* () = check_1 t c1 in + let* () = check_2 t c2 in + let* () = finalise_gc t in + let* () = check_not_found t c1 "removed c1" in + let* () = check_2 t c2 in + S.Repo.close t.repo + + (** Check adding new objects during a gc and finding them after the gc. *) + let add_during_gc ~lru_size () = + let* t = init ~lru_size () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + [%log.debug "Gc c1 keep c2"]; + let* () = start_gc t c2 in + let* t = checkout_exn t c2 in + let* t, c3 = commit_3 t in + let* () = finalise_gc t in + let* () = check_not_found t c1 "removed c1" in + let* () = check_2 t c2 in + let* () = check_3 t c3 in + S.Repo.close t.repo + + (** Check adding new objects during a gc and finding them after the gc. *) + let several_gc ~lru_size () = + let* t = init ~lru_size () in + let* t, c1 = commit_1 t in + let* () = start_gc t c1 in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* () = finalise_gc t in + let* () = start_gc t c2 in + let* t = checkout_exn t c2 in + let* t, c3 = commit_3 t in + let* () = finalise_gc t in + let* () = start_gc t c3 in + let* t = checkout_exn t c3 in + let* t, c4 = commit_4 t in + let* () = finalise_gc t in + let* () = start_gc t c4 in + let* t = checkout_exn t c4 in + let* t, c5 = commit_5 t in + let* () = finalise_gc t in + let* () = check_not_found t c1 "removed c1" in + let* () = check_not_found t c2 "removed c2" in + let* () = check_not_found t c3 "removed c3" in + let* () = check_4 t c4 in + let* () = check_5 t c5 in + S.Repo.close t.repo + + let find_during_gc_with_lru = find_during_gc ~lru_size:100 + let add_during_gc_with_lru = add_during_gc ~lru_size:100 + let several_gc_with_lru = several_gc ~lru_size:100 + let find_during_gc = find_during_gc ~lru_size:0 + let add_during_gc = add_during_gc ~lru_size:0 + let several_gc = several_gc ~lru_size:0 + + (** Check that RO can find old objects during gc. Also that RO can still find + removed objects before a call to [reload]. *) + let ro_find_during_gc () = + let* t = init () in + let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + [%log.debug "Gc c1 keep c2"]; + let* () = start_gc t c2 in + S.reload ro_t.repo; + let* () = check_1 ro_t c1 in + S.reload ro_t.repo; + let* () = check_2 ro_t c2 in + let* () = finalise_gc t in + let* () = check_1 ro_t c1 in + let* () = check_2 ro_t c2 in + S.reload ro_t.repo; + let* () = check_not_found ro_t c1 "removed c1" in + let* () = check_2 t c2 in + let* () = S.Repo.close t.repo in + S.Repo.close ro_t.repo + + (** Check that RO can find objects added during gc, but only after a call to + [reload]. *) + let ro_add_during_gc () = + let* t = init () in + let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + [%log.debug "Gc c1 keep c2"]; + let* () = start_gc t c2 in + S.reload ro_t.repo; + let* t = checkout_exn t c2 in + let* t, c3 = commit_3 t in + S.reload ro_t.repo; + let* t = checkout_exn t c2 in + let* t, c4 = commit_4 t in + let* () = finalise_gc t in + let* () = check_not_found ro_t c4 "not yet loaded c4" in + let* () = check_1 ro_t c1 in + let* () = check_2 ro_t c2 in + let* () = check_3 ro_t c3 in + S.reload ro_t.repo; + let* () = check_not_found ro_t c1 "removed c1" in + let* () = check_4 ro_t c4 in + let* () = S.Repo.close t.repo in + S.Repo.close ro_t.repo + + (** Check that RO can call [reload] during a second gc, even after no reloads + occured during the first gc. *) + let ro_reload_after_second_gc () = + let* t = init () in + let* ro_t = init ~readonly:true ~fresh:false ~root:t.root () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + [%log.debug "Gc c1 keep c2"]; + let* () = start_gc t c2 in + let* () = finalise_gc t in + let* t = checkout_exn t c2 in + let* t, c3 = commit_3 t in + [%log.debug "Gc c2 keep c3"]; + let* () = start_gc t c3 in + let* () = finalise_gc t in + S.reload ro_t.repo; + let* () = check_not_found ro_t c1 "removed c1" in + let* () = check_not_found ro_t c2 "removed c2" in + let* () = check_3 t c3 in + let* () = S.Repo.close t.repo in + S.Repo.close ro_t.repo + + (** Check that calling close during a gc kills the gc without finalising it. + On reopening the store, the following gc works fine. *) + let close_during_gc () = + let* t = init () in + let* t, c1 = commit_1 t in + let* () = start_gc t c1 in + let* () = S.Repo.close t.repo in + let* t = init ~readonly:false ~fresh:false ~root:t.root () in + let* () = check_1 t c1 in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* () = start_gc t c2 in + let* () = finalise_gc t in + let* t = checkout_exn t c2 in + S.Repo.close t.repo + + (** Check skipping a gc. *) + let test_skip () = + let* t = init () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* () = start_gc t c2 in + let* t = checkout_exn t c2 in + let* t, c3 = commit_3 t in + let* () = start_gc ~throttle:`Skip t c3 in + let* () = finalise_gc t in + let* () = check_not_found t c1 "removed c1" in + let* () = check_2 t c2 in + let* () = check_3 t c3 in + S.Repo.close t.repo + + (** Check blocking a gc, while waiting for the previous one to finish. *) + let test_block () = + let* t = init () in + let* t, c1 = commit_1 t in + let* () = start_gc t c1 in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* () = start_gc ~throttle:`Block t c2 in + let* t = checkout_exn t c2 in + let* t, c3 = commit_3 t in + let* () = start_gc ~throttle:`Block t c3 in + let* () = finalise_gc t in + let* () = check_not_found t c1 "removed c1" in + let* () = check_not_found t c2 "removed c2" in + let* () = check_3 t c3 in + S.Repo.close t.repo + + let test_skip_then_block () = + let* t = init () in + let* t, c1 = commit_1 t in + let* () = start_gc t c1 in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* () = start_gc t c2 in + let* t = checkout_exn t c2 in + let* t, c3 = commit_3 t in + let* () = start_gc ~throttle:`Skip t c3 in + let* () = start_gc ~throttle:`Block t c3 in + let* () = finalise_gc t in + let* () = check_not_found t c1 "removed c1" in + let* () = check_not_found t c2 "removed c2" in + let* () = check_3 t c3 in + S.Repo.close t.repo + + let kill_gc t = + let repo : S.Repo.t = t.repo in + match (repo.during_gc : S.X.during_gc option) with + | None -> Alcotest.failf "during_gc missing after call to start" + | Some { task; _ } -> ( + try + Irmin_pack_unix.Io.Unix.cancel task; + true + with Unix.Unix_error (Unix.ESRCH, "kill", _) -> false) + + let test_kill_gc_and_finalise () = + let* t = init () in + let* t, c1 = commit_1 t in + let* () = start_gc t c1 in + let killed = kill_gc t in + let* () = + if killed then + Alcotest.check_raises_lwt "Gc process killed" + (Irmin_pack_unix.Errors.Pack_error + (`Gc_process_died_without_result_file + "cancelled \"No_such_file_or_directory\"")) + (fun () -> finalise_gc t) + else Lwt.return_unit + in + S.Repo.close t.repo + + let test_kill_gc_and_close () = + let* t = init () in + let* t, c1 = commit_1 t in + let* () = start_gc t c1 in + let _killed = kill_gc t in + S.Repo.close t.repo + + let test_finalise_hook () = + let* t = init () in + let* t, c1 = commit_1 t in + let* t = checkout_exn t c1 in + let* t, c2 = commit_2 t in + let* () = start_gc t c2 in + let c3 = ref None in + let hook = function + | `Before_latest_newies -> + let* t = checkout_exn t c2 in + let* _, c = commit_3 t in + c3 := Some c; + Lwt.return_unit + in + let* wait = S.finalise_gc_with_hook ~wait:true ~hook t.repo in + assert wait; + let c3 = Option.get !c3 in + let* () = check_3 t c3 in + S.Repo.close t.repo + + let tests = + [ + tc "Test find_during_gc" find_during_gc; + tc "Test add_during_gc" add_during_gc; + tc "Test several_gc" several_gc; + tc "Test find_during_gc_with_lru" find_during_gc_with_lru; + tc "Test add_during_gc_with_lru" add_during_gc_with_lru; + tc "Test several_gc_with_lru" several_gc_with_lru; + tc "Test ro_find_during_gc" ro_find_during_gc; + tc "Test ro_add_during_gc" ro_add_during_gc; + tc "Test ro_reload_after_second_gc" ro_reload_after_second_gc; + tc "Test close_during_gc" close_during_gc; + tc "Test skip gc" test_skip; + tc "Test block gc" test_block; + tc "Test skip_then_block gc" test_skip_then_block; + tc "Test kill gc and finalise" test_kill_gc_and_finalise; + tc "Test kill gc and close" test_kill_gc_and_close; + tc "Test finalise with hook" test_finalise_hook; + ] +end diff --git a/vendors/irmin/test/irmin-pack/test_gc.mli b/vendors/irmin/test/irmin-pack/test_gc.mli new file mode 100644 index 0000000000000000000000000000000000000000..edf8103aed382674eb610a8de3ac98eba2466107 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_gc.mli @@ -0,0 +1,23 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Blocking_gc : sig + val tests : unit Alcotest_lwt.test_case list +end + +module Concurrent_gc : sig + val tests : unit Alcotest_lwt.test_case list +end diff --git a/vendors/irmin/test/irmin-pack/test_hashes.ml b/vendors/irmin/test/irmin-pack/test_hashes.ml new file mode 100644 index 0000000000000000000000000000000000000000..0aecf77c8eac86802ff03b413651aff35b60c926 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_hashes.ml @@ -0,0 +1,321 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +let root = Filename.concat "_build" "test-irmin-tezos" + +let conf = + Irmin_pack.config ~readonly:false ~fresh:true ~index_log_size:1000 root + +let zero = Bytes.make 10 '0' + +let hash_zero = + "d81e60258ecc8bd7064c8703888aececfc54e29ff94f7a2d9a84667a500548e1" + +let bindings steps = List.map (fun x -> ([ x ], zero)) steps + +let check_string ~msg ~expected ~got = + let got = Hex.of_string got |> Hex.show in + Alcotest.(check string) (Fmt.str "%s" msg) expected got + +let check_iter iter_type (iter : 'a -> (string -> unit) -> unit) v checks = + let counter = ref 0 in + iter v (fun x -> + match List.nth_opt checks !counter with + | None -> Alcotest.failf "No more calls to %s left" iter_type + | Some (msg, expected) -> + let msg = Fmt.str "Check %s:%s" iter_type msg in + check_string ~msg ~expected ~got:x; + incr counter); + if !counter <> List.length checks then + Alcotest.failf "More calls to %s expected" iter_type + +module Test + (Conf : Irmin_pack.Conf.S) + (Schema : Irmin.Schema.Extended + with type Contents.t = bytes + and type Metadata.t = unit + and type Path.t = string list + and type Path.step = string + and type Branch.t = string + and module Info = Irmin.Info.Default) = +struct + module Store = struct + module Maker = Irmin_pack_unix.Maker (Conf) + include Maker.Make (Schema) + end + + include Store + + let build_tree steps = + let bindings = bindings steps in + let tree = Tree.empty () in + let+ tree = + Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + in + tree + + let persist_tree tree = + let* repo = Repo.v conf in + let* init_commit = + Commit.v ~parents:[] ~info:Info.empty repo + (Tree.singleton [ "singleton-step" ] (Bytes.of_string "singleton-val")) + in + let h = Commit.hash init_commit in + let info = Info.v ~author:"Tezos" 0L in + let* commit = + Commit.v ~parents:[ Irmin_pack.Pack_key.v_indexed h ] ~info repo tree + in + let tree = Commit.tree commit in + Lwt.return (repo, tree, commit) + + let check_hardcoded_hash msg expected got = + let got = (Irmin.Type.to_string Store.Hash.t) got in + Alcotest.(check string) + (Fmt.str "Check hardcoded hash: %s" msg) + expected got +end + +module Test_tezos_conf = struct + module Store = Test (Irmin_tezos.Conf) (Irmin_tezos.Schema) + module Contents = Store.Backend.Contents + module Node = Store.Backend.Node + module Commit = Store.Backend.Commit + + let hash_root_small_tree = + "83722c2791a1c47dada4718656a20a2f3a063ae9945b475e67bbb6ef29d88ca4" + + let contents_hash () = + let h0 = Contents.Hash.hash zero in + let encode_bin_hash = Irmin.Type.(unstage (encode_bin Contents.Hash.t)) in + encode_bin_hash h0 (fun x -> + check_string ~msg:"Check encode_bin: h0" ~expected:hash_zero ~got:x); + let encode_bin_val = Irmin.Type.(unstage (encode_bin Contents.Val.t)) in + let checks = + [ ("header of zero", "0a"); ("zero", "30303030303030303030") ] + in + check_iter "encode_bin" encode_bin_val zero checks; + let pre_hash_val = Irmin.Type.(unstage (pre_hash Contents.Val.t)) in + let checks = + [ + ("header of zero", "000000000000000a"); ("zero", "30303030303030303030"); + ] + in + check_iter "pre_hash" pre_hash_val zero checks; + Store.check_hardcoded_hash "contents hash" + "CoWHVKM5r2eiHQxhicqakkr5FwJfabahGBwCCWzRPCNPs79CoZty" h0; + Lwt.return_unit + + let some_steps = [ "00"; "01" ] + + let checks_bindings_pre_hash steps = + let nb_steps = Fmt.str "%016x" (List.length steps) in + let checks = + List.fold_left + (fun acc s -> + let hex = Hex.of_string s |> Hex.show in + let check_step = + [ + ("node type is contents", "ff00000000000000"); + ("len of step ", "02"); + (s, hex); + ("len of contents hash", "0000000000000020"); + ("hash of contents", hash_zero); + ] + |> List.rev + in + check_step @ acc) + [] steps + |> List.rev + in + ("len of values", nb_steps) :: checks + + let inode_values_hash () = + let* tree = Store.build_tree some_steps in + let* repo, tree, _ = Store.persist_tree tree in + let* root_node = + match Store.Tree.destruct tree with + | `Contents _ -> Alcotest.fail "Expected root to be node" + | `Node x -> Store.to_backend_node x + in + let h = Node.Hash.hash root_node in + let encode_bin_hash = Irmin.Type.(unstage (encode_bin Node.Hash.t)) in + encode_bin_hash h (fun x -> + check_string ~msg:"Check encode_bin: node hash" + ~expected:hash_root_small_tree ~got:x); + let pre_hash_val = Irmin.Type.(unstage (pre_hash Node.Val.t)) in + let checks = checks_bindings_pre_hash some_steps in + check_iter "pre_hash" pre_hash_val root_node checks; + Store.check_hardcoded_hash "node hash" + "CoVeCU4o3dqmfdwqt2vh8LDz9X6qGbTUyLhgVvFReyzAvTf92AKx" h; + let* () = Store.Repo.close repo in + Lwt.return_unit + + let commit_hash () = + let* tree = Store.build_tree some_steps in + let* repo, _, commit = Store.persist_tree tree in + let commit_val = Store.to_backend_commit commit in + let h = Commit.Hash.hash commit_val in + let encode_bin_hash = Irmin.Type.(unstage (encode_bin Commit.Hash.t)) in + encode_bin_hash h (fun x -> + check_string ~msg:"commit hash" + ~expected: + "c20860adda3c3d40d8d03fab22b07e889979cdac880d979711aa852a0896ae30" + ~got:x); + let checks = + [ + ("hash of root node", hash_root_small_tree); + ("len of parents", "01"); + ( "parent hash", + "634d894802f9032ef48bbe1253563dbeb2aad7dc684da83bdea5692fde2185ae" ); + ("date", "0000000000000000"); + ("len of author", "05"); + ("author", "54657a6f73"); + ("len of message", "00"); + ("message", ""); + ] + in + let encode_bin_val = Irmin.Type.(unstage (encode_bin Commit.Val.t)) in + check_iter "encode_bin" encode_bin_val commit_val checks; + let checks = + [ + ("len of node hash", "0000000000000020"); + ("hash of root node", hash_root_small_tree); + ("len of parents", "0000000000000001"); + ("len of parent hash", "0000000000000020"); + ( "parent hash", + "634d894802f9032ef48bbe1253563dbeb2aad7dc684da83bdea5692fde2185ae" ); + ("date", "0000000000000000"); + ("len of author", "0000000000000005"); + ("author", "54657a6f73"); + ("len of message", "0000000000000000"); + ("message", ""); + ] + in + let pre_hash_val = Irmin.Type.(unstage (pre_hash Commit.Val.t)) in + check_iter "pre_hash" pre_hash_val commit_val checks; + Store.check_hardcoded_hash "commit hash" + "CoW7mALEs2vue5cfTMdJfSAjNmjmALYS1YyqSsYr9siLcNEcrvAm" h; + let* () = Store.Repo.close repo in + Lwt.return_unit +end + +module Test_small_conf = struct + module Conf = struct + let entries = 2 + let stable_hash = 3 + let contents_length_header = Some `Varint + let inode_child_order = `Seeded_hash + let forbid_empty_dir_persistence = true + end + + module Store = Test (Conf) (Irmin_tezos.Schema) + module Node = Store.Backend.Node + + let many_steps = [ "00"; "01"; "02"; "03"; "04"; "05" ] + + let checks = + [ + ("inode tree", "01"); + ("depth", "00"); + ("len of tree", "06"); + ("d", "02"); + ("e", "00"); + ("g", "aa670a7e66b80a4d5f0e2e35b0c7fc4fa8d3e2d62a8b90eb2ff1d184dde9d0fa"); + ("b1", "01"); + ( "hash ", + "821707c86f7030b1102397feb88d454076ec64744dfd9811b8254bd61d396cfe" ); + ] + + let inode_tree_hash () = + let* tree = Store.build_tree many_steps in + let* repo, tree, _ = Store.persist_tree tree in + let* root_node = + match Store.Tree.destruct tree with + | `Contents _ -> Alcotest.fail "Expected root to be node" + | `Node x -> Store.to_backend_node x + in + let h = Node.Hash.hash root_node in + let pre_hash_hash = Irmin.Type.(unstage (pre_hash Node.Hash.t)) in + pre_hash_hash h (fun x -> + check_string ~msg:"node hash" + ~expected: + "e670a325ac78b2b6949b8f9fa448b17aa708ef39eb29c9e364be473f988329ea" + ~got:x); + let pre_hash_val = Irmin.Type.(unstage (pre_hash Node.Val.t)) in + check_iter "pre_hash" pre_hash_val root_node checks; + Store.check_hardcoded_hash "node hash" + "CoWPo8s8h81q8skRqfPLTAJvq4ioFKS6rQhdRcY5nd6HQz2upwp4" h; + let* () = Store.Repo.close repo in + Lwt.return_unit +end + +module Test_V1 = struct + module Schema = struct + include Irmin_tezos.Schema + + module Commit + (Node_key : Irmin.Key.S with type hash = Hash.t) + (Commit_key : Irmin.Key.S with type hash = Hash.t) = + struct + module M = Irmin.Commit.Generic_key.Make (Hash) (Node_key) (Commit_key) + module Commit = Irmin.Commit.V1.Make (Hash) (M) + include Commit + end + end + + module Store = Test (Conf) (Schema) + module Commit = Store.Backend.Commit + + let many_steps = [ "00"; "01"; "02"; "03"; "04"; "05" ] + + let commit_hash () = + let* tree = Store.build_tree many_steps in + let* repo, _, commit = Store.persist_tree tree in + let commit_val = Store.to_backend_commit commit in + let checks = + [ + ("len of node hash", "0000000000000020"); + ( "hash of root node", + "3ab1c8feb08812cd1ffd8ec1ca4f861a578b700fa7dd9daab4c63d4e86638f99" ); + ("len of parents", "0000000000000001"); + ("len of parent hash", "0000000000000020"); + ( "parent hash", + "634d894802f9032ef48bbe1253563dbeb2aad7dc684da83bdea5692fde2185ae" ); + ("date", "0000000000000000"); + ("len of author", "0000000000000005"); + ("author", "54657a6f73"); + ("len of message", "0000000000000000"); + ("message", ""); + ] + in + let encode_bin_val = Irmin.Type.(unstage (encode_bin Commit.Val.t)) in + check_iter "encode_bin" encode_bin_val commit_val checks; + let* () = Store.Repo.close repo in + Lwt.return_unit +end + +let tests = + let tc name f = Alcotest_lwt.test_case name `Quick (fun _switch -> f) in + [ + tc "contents hash" Test_tezos_conf.contents_hash; + tc "inode_values hash" Test_tezos_conf.inode_values_hash; + tc "inode_tree hash" Test_small_conf.inode_tree_hash; + tc "commit hash" Test_tezos_conf.commit_hash; + tc "V1 commit hash" Test_V1.commit_hash; + ] diff --git a/vendors/irmin/test/irmin-pack/test_hashes.mli b/vendors/irmin/test/irmin-pack/test_hashes.mli new file mode 100644 index 0000000000000000000000000000000000000000..5502f37745f8a21dee3eef29618836868723d4ef --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_hashes.mli @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val tests : unit Alcotest_lwt.test_case list + +val check_iter : + string -> + ('a -> (string -> unit) -> unit) -> + 'a -> + (string * string) list -> + unit diff --git a/vendors/irmin/test/irmin-pack/test_inode.ml b/vendors/irmin/test/irmin-pack/test_inode.ml new file mode 100644 index 0000000000000000000000000000000000000000..e261e9872364e6b1bbf975f8fdb4dedfca1c614e --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_inode.ml @@ -0,0 +1,916 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +let root = Filename.concat "_build" "test-inode" +let src = Logs.Src.create "tests.instances" ~doc:"Tests" + +module Log = (val Logs.src_log src : Logs.LOG) + +let check_iter = Test_hashes.check_iter + +module Inode_modules + (Conf : Irmin_pack.Conf.S) + (Schema : Irmin.Schema.S) (Contents : sig + val foo : Schema.Contents.t + val bar : Schema.Contents.t + end) = +struct + module Key = Irmin_pack.Pack_key.Make (Schema.Hash) + + module Node = + Irmin.Node.Generic_key.Make_v2 (Schema.Hash) (Schema.Path) (Schema.Metadata) + (Key) + (Key) + + module Index = Irmin_pack_unix.Index.Make (Schema.Hash) + + module Inter = + Irmin_pack.Inode.Make_internal (Conf) (Schema.Hash) (Key) (Node) + + module Io = Irmin_pack_unix.Io.Unix + module Errs = Irmin_pack_unix.Io_errors.Make (Io) + module Control = Irmin_pack_unix.Control_file.Make (Io) + module Aof = Irmin_pack_unix.Append_only_file.Make (Io) + + module File_manager = + Irmin_pack_unix.File_manager.Make (Control) (Aof) (Aof) (Index) (Errs) + + module Dict = Irmin_pack_unix.Dict.Make (File_manager) + module Dispatcher = Irmin_pack_unix.Dispatcher.Make (File_manager) + + module Pack = + Irmin_pack_unix.Pack_store.Make (File_manager) (Dict) (Dispatcher) + (Schema.Hash) + (Inter.Raw) + (Errs) + + module Inode = + Irmin_pack_unix.Inode.Make_persistent (Schema.Hash) (Node) (Inter) (Pack) + + module Contents_value = + Irmin_pack.Pack_value.Of_contents (Conf) (Schema.Hash) (Key) + (Schema.Contents) + + module Contents_store = + Irmin_pack_unix.Pack_store.Make (File_manager) (Dict) (Dispatcher) + (Schema.Hash) + (Contents_value) + (Errs) + + module Context = struct + type t = { + store : read Inode.t; + store_contents : read Contents_store.t; + fm : File_manager.t; + (* Two contents values that are guaranteed to be read by {!store}: *) + foo : Key.t; + bar : Key.t; + } + + let config ~indexing_strategy ~readonly ~fresh name = + let module Index = Irmin_pack.Indexing_strategy in + let indexing_strategy = + if indexing_strategy = `always then Index.always else Index.minimal + in + Irmin_pack.Conf.init ~fresh ~readonly ~indexing_strategy ~lru_size:0 name + + (* TODO : remove duplication with irmin_pack/ext.ml *) + let get_fm config = + let readonly = Irmin_pack.Conf.readonly config in + + if readonly then File_manager.open_ro config |> Errs.raise_if_error + else + let fresh = Irmin_pack.Conf.fresh config in + let root = Irmin_pack.Conf.root config in + (* make sure the parent dir exists *) + let () = + match Sys.is_directory (Filename.dirname root) with + | false -> Unix.mkdir (Filename.dirname root) 0o755 + | true -> () + in + match (Io.classify_path root, fresh) with + | `No_such_file_or_directory, _ -> + File_manager.create_rw ~overwrite:false config + |> Errs.raise_if_error + | `Directory, true -> + File_manager.create_rw ~overwrite:true config |> Errs.raise_if_error + | `Directory, false -> + File_manager.open_rw config |> Errs.raise_if_error + | (`File | `Other), _ -> Errs.raise_error (`Not_a_directory root) + + let get_store ~indexing_strategy () = + [%log.app "Constructing a fresh context for use by the test"]; + rm_dir root; + let config = config ~indexing_strategy ~readonly:false ~fresh:true root in + let fm = get_fm config in + let dict = Dict.v fm |> Errs.raise_if_error in + let dispatcher = Dispatcher.v ~root fm |> Errs.raise_if_error in + let store = Inode.v ~config ~fm ~dict ~dispatcher in + let store_contents = Contents_store.v ~config ~fm ~dict ~dispatcher in + let+ foo, bar = + Contents_store.batch store_contents (fun writer -> + let* foo = Contents_store.add writer Contents.foo in + let* bar = Contents_store.add writer Contents.bar in + Lwt.return (foo, bar)) + in + [%log.app "Test context constructed"]; + { store; store_contents; fm; foo; bar } + + let close t = + File_manager.close t.fm |> Errs.raise_if_error; + (* closes dict, inodes and contents store. *) + Lwt.return_unit + end +end + +module Conf = struct + let entries = 2 + let stable_hash = 3 + let contents_length_header = Some `Varint + let inode_child_order = `Seeded_hash + let forbid_empty_dir_persistence = false +end + +module String_contents = struct + let foo = "foo" + let bar = "bar" +end + +module S = Inode_modules (Conf) (Schema) (String_contents) +open S +open Schema + +type pred = [ `Contents of Key.t | `Inode of Key.t | `Node of Key.t ] +[@@deriving irmin] + +let pp_pred = Irmin.Type.pp pred_t + +module H_contents = Irmin.Hash.Typed (Hash) (Schema.Contents) + +let normal x = `Contents (x, Metadata.default) +let node x = `Node x +let check_hash = Alcotest.check_repr Inode.Val.hash_t +let check_values = Alcotest.check_repr Inode.Val.t + +let check_int pos ?(msg = "") ~expected actual = + Alcotest.(check ~pos int) msg expected actual + +(* Exhaustive inode structure generator *) +module Inode_permutations_generator = struct + type step = string + type content = Inode.Val.value + type inode = Inode.value + + module StepMap = Map.Make (struct + type t = step + + let compare = compare + end) + + module StepSet = Set.Make (struct + type t = Path.step + + let compare = compare + end) + + module StepSetMap = Map.Make (struct + type t = StepSet.t + + let compare = StepSet.compare + end) + + type t = { + steps : step list; + content_per_step : content StepMap.t; + steps_per_tree : StepSet.t list; + trees : inode list; + tree_per_steps : inode StepSetMap.t; + } + + (** [gen_step index_list] uses brute force to generate a step such that + [Inter.Val.index ~depth:i] maps to the ith index in the [index_list]. *) + let gen_step : int list -> Path.step = + let tbl = Hashtbl.create 10 in + let max_brute_force_iterations = 100 in + let letters_per_step = (max_brute_force_iterations + 25) / 26 in + fun indices -> + let rec aux i = + if i > max_brute_force_iterations then + failwith "Could not quickly generate a step" + else + let s = Common.random_letters letters_per_step in + let is_valid = + indices + |> List.mapi (fun depth i -> (depth, i)) + |> List.for_all (fun (depth, i) -> Inter.Val.index ~depth s = i) + in + if is_valid then s else aux (i + 1) + in + match Hashtbl.find_opt tbl indices with + | Some s -> s + | None -> + let s = aux 0 in + Hashtbl.add tbl indices s; + s + + (** List all the steps that would fill a tree of depth [maxdepth_of_test]. *) + let gen_steps entries maxdepth_of_test : step list = + let ( ** ) a b = float_of_int a ** float_of_int b |> int_of_float in + List.init (entries ** maxdepth_of_test) (fun i -> + List.init maxdepth_of_test (fun j -> + let j = entries ** (maxdepth_of_test - j - 1) in + (* In the binary case (Conf.entries = 2), [j] is now the mask of the + bit to look at *) + i / j mod entries)) + |> List.map gen_step + + let powerset xs = + List.fold_left + (fun acc x -> acc @ List.map (fun ys -> x :: ys) acc) + [ [] ] xs + + let v ~entries ~maxdepth_of_test = + let ( ** ) a b = float_of_int a ** float_of_int b |> int_of_float in + let steps = gen_steps entries maxdepth_of_test in + let content_per_step = + List.map + (fun s -> (s, H_contents.hash s |> Key.unfindable_of_hash |> normal)) + steps + |> List.to_seq + |> StepMap.of_seq + in + let steps_per_tree : StepSet.t list = + powerset steps |> List.map List.to_seq |> List.map StepSet.of_seq + in + Alcotest.(check int) + "Size of the powerset" + (List.length steps_per_tree) + (2 ** entries ** maxdepth_of_test); + let trees : Inode.value list = + List.map + (fun steps -> + let steps = StepSet.elements steps in + let contents = + List.map (fun s -> StepMap.find s content_per_step) steps + in + List.combine steps contents |> Inode.Val.of_list) + steps_per_tree + in + let tree_per_steps : Inode.value StepSetMap.t = + List.combine steps_per_tree trees |> List.to_seq |> StepSetMap.of_seq + in + { steps; content_per_step; steps_per_tree; trees; tree_per_steps } + + (** [steps t] is a list of length [entries ^ maxdepth_of_test] (8) containing + the necessary steps to fill a tree of depth equal to [maxdepth_of_test] + (3). *) + let steps : t -> step list = fun { steps; _ } -> steps + + let content_of_step : t -> step -> content = + fun { content_per_step; _ } s -> StepMap.find s content_per_step + + (** [trees t] is a list of length [2 ^ (entries ^ maxdepth_of_test)] (256) + containing pairs of steps set/inode tree. This list is formed from the + powerset of [steps t], it contains all the possible structural + permutations for an inode tree of depth equal to [maxdepth_of_test] and + width equal to [entries]. *) + let trees : t -> (StepSet.t * Inode.value) list = + fun { trees; steps_per_tree; _ } -> List.combine steps_per_tree trees + + (** [tree_of_steps t ss] is the inode tree associated to [ss] in [trees t]. + + E.g, [tree_of_steps t StepSet.empty] is the empty inode. *) + let tree_of_steps : t -> StepSet.t -> Inode.value = + fun { tree_per_steps; _ } steps -> StepSetMap.find steps tree_per_steps +end + +let check_node msg v t = + let hash = Inter.Val.hash_exn v in + let+ key = Inode.batch t.Context.store (fun i -> Inode.add i v) in + let hash' = Key.to_hash key in + check_hash msg hash hash' + +let check_hardcoded_hash msg h v = + h |> Irmin.Type.of_string Inode.Val.hash_t |> function + | Error (`Msg str) -> Alcotest.failf "hash of string failed: %s" str + | Ok hash -> check_hash msg hash (Inter.Val.hash_exn v) + +(** Test add values from an empty node. *) +let test_add_values ~indexing_strategy = + rm_dir root; + let* t = Context.get_store ~indexing_strategy () in + let { Context.foo; bar; _ } = t in + check_node "hash empty node" (Inode.Val.empty ()) t >>= fun () -> + let v1 = Inode.Val.add (Inode.Val.empty ()) "x" (normal foo) in + let v2 = Inode.Val.add v1 "y" (normal bar) in + check_node "node x+y" v2 t >>= fun () -> + check_hardcoded_hash "hash v2" "d4b55db5d2d806283766354f0d7597d332156f74" v2; + let v3 = Inode.Val.of_list [ ("x", normal foo); ("y", normal bar) ] in + check_values "add x+y vs v x+y" v2 v3; + Context.close t + +let test_add_values () = + let* () = test_add_values ~indexing_strategy:`always in + test_add_values ~indexing_strategy:`minimal + +let integrity_check ?(stable = true) v = + Alcotest.(check bool) "check stable" (Inter.Val.stable v) stable; + if not (Inter.Val.integrity_check v) then + Alcotest.failf "node does not satisfy stability invariants %a" + (Irmin.Type.pp Inode.Val.t) + v + +(** Test add to inodes. *) +let test_add_inodes ~indexing_strategy = + rm_dir root; + let* t = Context.get_store ~indexing_strategy () in + let { Context.foo; bar; _ } = t in + let v1 = Inode.Val.of_list [ ("x", normal foo); ("y", normal bar) ] in + let v2 = Inode.Val.add v1 "z" (normal foo) in + let v3 = + Inode.Val.of_list + [ ("x", normal foo); ("z", normal foo); ("y", normal bar) ] + in + check_values "add x+y+z vs v x+z+y" v2 v3; + check_hardcoded_hash "hash v3" "46fe6c68a11a6ecd14cbe2d15519b6e5f3ba2864" v3; + integrity_check v1; + integrity_check v2; + let v4 = Inode.Val.add v2 "a" (normal foo) in + let v5 = + Inode.Val.of_list + [ + ("x", normal foo); + ("z", normal foo); + ("a", normal foo); + ("y", normal bar); + ] + in + check_values "add x+y+z+a vs v x+z+a+y" v4 v5; + check_hardcoded_hash "hash v4" "c330c08571d088141dfc82f644bffcfcf6696539" v4; + integrity_check v4 ~stable:false; + Context.close t + +let test_add_inodes () = + let* () = test_add_inodes ~indexing_strategy:`always in + test_add_inodes ~indexing_strategy:`minimal + +(** Test remove values on an empty node. *) +let test_remove_values ~indexing_strategy = + rm_dir root; + let* t = Context.get_store ~indexing_strategy () in + let { Context.foo; bar; _ } = t in + let v1 = Inode.Val.of_list [ ("x", normal foo); ("y", normal bar) ] in + let v2 = Inode.Val.remove v1 "y" in + let v3 = Inode.Val.of_list [ ("x", normal foo) ] in + check_values "node x obtained two ways" v2 v3; + check_hardcoded_hash "hash v2" "a1996f4309ea31cc7ba2d4c81012885aa0e08789" v2; + let v4 = Inode.Val.remove v2 "x" in + check_node "remove results in an empty node" (Inode.Val.empty ()) t + >>= fun () -> + let v5 = Inode.Val.remove v4 "x" in + check_values "remove on an already empty node" v4 v5; + check_hardcoded_hash "hash v4" "5ba93c9db0cff93f52b521d7420e43f6eda2784f" v4; + Alcotest.(check bool) "v5 is empty" (Inode.Val.is_empty v5) true; + Context.close t + +let test_remove_values () = + let* () = test_remove_values ~indexing_strategy:`always in + test_remove_values ~indexing_strategy:`minimal + +(** Test remove and add values to go from stable to unstable inodes. *) +let test_remove_inodes ~indexing_strategy = + rm_dir root; + let* t = Context.get_store ~indexing_strategy () in + let { Context.foo; bar; _ } = t in + let v1 = + Inode.Val.of_list + [ ("x", normal foo); ("y", normal bar); ("z", normal foo) ] + in + check_hardcoded_hash "hash v1" "46fe6c68a11a6ecd14cbe2d15519b6e5f3ba2864" v1; + let v2 = Inode.Val.remove v1 "x" in + let v3 = Inode.Val.of_list [ ("y", normal bar); ("z", normal foo) ] in + check_values "node y+z obtained two ways" v2 v3; + check_hardcoded_hash "hash v2" "ea22a2936eed53978bde62f0185cee9d8bbf9489" v2; + let v4 = + Inode.Val.of_list + [ + ("x", normal foo); + ("z", normal foo); + ("a", normal foo); + ("y", normal bar); + ] + in + let v5 = Inode.Val.remove v4 "a" in + check_values "node x+y+z obtained two ways" v1 v5; + integrity_check v1; + integrity_check v5; + Context.close t + +let test_remove_inodes () = + let* () = test_remove_inodes ~indexing_strategy:`always in + test_remove_inodes ~indexing_strategy:`minimal + +(** For each of the 256 possible inode trees with [depth <= 3] and + [width = Conf.entries = 2] built by [Inode.Val.v], assert that + independently, all the possible [Inode.Val.add]/[Inode.Val.remove] + operations yield a tree computable by [Inode.Val.v]. + + In other words. Let [T] be the set of all possible trees (256). Let [O] be + the set of unitary [tree -> tree] operations (8). If all the combinations of + [T] and [O] yield trees in [T] then, by induction, the representation is + unique. + + Caveats + + If something breaks at [depth > 3 || entries <> 2], this won't be caught + here. + + If a corrupted tree is constructed using [Elt.decode_bin] and [Val.of_bin], + this won't be caught here. + + If a corrupted subtree is loaded through the [find] function when an inode + lazily loads subtrees, this won't be caught here. *) +let test_representation_uniqueness_maxdepth_3 () = + let module P = Inode_permutations_generator in + let p = P.v ~entries:Conf.entries ~maxdepth_of_test:3 in + let f steps tree s = + (* [steps, tree] is one of the known pair built using [Val.v]. Let's try to + add or remove [s] from it and see if something breaks. *) + if P.StepSet.mem s steps then + let steps' = P.StepSet.remove s steps in + let tree'_ref = P.tree_of_steps p steps' in + let tree'_new = Inode.Val.remove tree s in + check_values + "The representation of the received tree obtained through [remove] \ + differs from the expected one obtained through [v]." + tree'_ref tree'_new + else + let steps' = P.StepSet.add s steps in + let c = P.content_of_step p s in + let tree'_ref = P.tree_of_steps p steps' in + let tree'_new = Inode.Val.add tree s c in + check_values + "The representation of the received tree obtained through [remove] \ + differs from the expected one obtained through [v]." + tree'_ref tree'_new + in + List.iter + (fun (ss, t) -> List.iter (fun s -> f ss t s) (P.steps p)) + (P.trees p); + Lwt.return_unit + +let test_truncated_inodes ~indexing_strategy = + let* t = Context.get_store ~indexing_strategy () in + let { Context.foo; bar; _ } = t in + let to_truncated inode = + let encode, decode = + let t = Inode.Val.t in + Irmin.Type.(encode_bin t |> unstage, decode_bin t |> unstage) + in + let encode inode = + let buf = Buffer.create 0 in + encode inode (Buffer.add_string buf); + Buffer.contents buf + in + let decode str = decode str (ref 0) in + inode |> encode |> decode + in + let with_failure f = + Alcotest.check_raises + "Iteration on that Truncated inode with broken pointers was expected to \ + fail." + (Failure + "Impossible to load the subtree on an inode deserialized using Repr") f + in + let s00, s01, s11, s10 = + Inode_permutations_generator. + ( gen_step [ 0; 0 ], + gen_step [ 0; 1 ], + gen_step [ 1; 1 ], + gen_step [ 1; 0 ] ) + in + let iter_steps f = + List.iter (fun step -> f step |> ignore) [ s00; s01; s11; s10 ] + in + let iter_steps_with_failure f = + List.iter + (fun step -> with_failure (fun () -> f step |> ignore)) + [ s00; s01; s11; s10 ] + in + (* v1 is a Truncated inode of tag Values. No pointers. *) + let v1 = + Inode.Val.of_list [ (s00, normal foo); (s10, normal foo) ] |> to_truncated + in + Inode.Val.list v1 |> ignore; + (iter_steps @@ fun step -> Inode.Val.find v1 step); + (iter_steps @@ fun step -> Inode.Val.add v1 step (normal bar)); + (iter_steps @@ fun step -> Inode.Val.remove v1 step); + (* v2 is just a Truncated inode of tag Tree. The pointers are built after + the call to [to_truncated], they are [Intact]. *) + let v2 = Inode.Val.add v1 s01 (normal foo) in + Inode.Val.list v2 |> ignore; + (iter_steps @@ fun step -> Inode.Val.find v1 step); + (iter_steps @@ fun step -> Inode.Val.add v1 step (normal bar)); + (iter_steps @@ fun step -> Inode.Val.remove v1 step); + (* v3 is just a Truncated inode of tag Tree. The pointers are built before + the call to [to_truncated], they are [Broken]. *) + let v3 = + Inode.Val.of_list + [ (s00, normal foo); (s10, normal bar); (s01, normal bar) ] + |> to_truncated + in + (with_failure @@ fun () -> Inode.Val.list v3 |> ignore); + (iter_steps_with_failure @@ fun step -> Inode.Val.find v3 step); + (iter_steps_with_failure @@ fun step -> Inode.Val.add v3 step (normal bar)); + (iter_steps_with_failure @@ fun step -> Inode.Val.remove v3 step); + Context.close t + +let test_truncated_inodes () = + let* () = test_truncated_inodes ~indexing_strategy:`always in + test_truncated_inodes ~indexing_strategy:`minimal + +let test_intermediate_inode_as_root ~indexing_strategy = + let* t = Context.get_store ~indexing_strategy () in + let { Context.foo; bar; _ } = t in + let s000, s001, s010 = + Inode_permutations_generator. + (gen_step [ 0; 0; 0 ], gen_step [ 0; 0; 1 ], gen_step [ 0; 1; 0 ]) + in + let v0 = + Inode.Val.of_list + [ (s000, normal foo); (s001, normal bar); (s010, normal foo) ] + in + let* h_depth0 = Inode.batch t.store @@ fun store -> Inode.add store v0 in + let (`Inode h_depth1) = + match Inode.Val.pred v0 with + | [ (_, (`Inode _ as pred)) ] -> pred + | l -> + let l = List.map snd l in + Alcotest.failf + "Expected one `Inode predecessors, got [%a], a list of length %d." + Fmt.(list ~sep:(any " ; ") pp_pred) + l (List.length l) + in + + (* On inode with depth=0 *) + let* v = + Inode.find t.store h_depth0 >|= function + | None -> Alcotest.fail "Could not fetch inode from backend" + | Some v -> v + in + if Inode.Val.list v |> List.length <> 3 then + Alcotest.fail "Failed to list entries of loaded inode"; + let _ = Inode.Val.remove v s000 in + let _ = Inode.Val.add v s000 (normal foo) in + let* _ = Inode.batch t.store @@ fun store -> Inode.add store v in + + (* On inode with depth=1 *) + let* v = + Inode.find t.store h_depth1 >|= function + | None -> Alcotest.fail "Could not fetch inode from backend" + | Some v -> v + in + if Inode.Val.list v |> List.length <> 3 then + Alcotest.fail "Failed to list entries of loaded inode"; + let with_exn f = + Alcotest.check_raises + "Write-only operation is forbiden on intermediate inode" + (Failure "Cannot perform operation on non-root inode value.") (fun () -> + f () |> ignore) + in + with_exn (fun () -> Inode.Val.remove v s000); + with_exn (fun () -> Inode.Val.add v s000 (normal foo)); + let* () = + Inode.batch t.store (fun store -> + with_exn (fun () -> Inode.add store v); + Lwt.return_unit) + in + Lwt.return_unit + +let test_intermediate_inode_as_root () = + let* () = test_intermediate_inode_as_root ~indexing_strategy:`always in + test_intermediate_inode_as_root ~indexing_strategy:`minimal + +let test_concrete_inodes ~indexing_strategy = + let* t = Context.get_store ~indexing_strategy () in + let { Context.foo; bar; _ } = t in + let pp_concrete = Irmin.Type.pp_json ~minify:false Inter.Val.Concrete.t in + let result_t = Irmin.Type.result Inode.Val.t Inter.Val.Concrete.error_t in + let testable = + Alcotest.testable + (Irmin.Type.pp_json ~minify:false result_t) + Irmin.Type.(unstage (equal result_t)) + in + let check v = + let len = Inter.Val.length v in + integrity_check ~stable:(len <= Conf.stable_hash) v; + let c = Inter.Val.to_concrete v in + let r = Inter.Val.of_concrete c in + let msg = Fmt.str "%a" pp_concrete c in + Alcotest.check testable msg (Ok v) r + in + let v = Inode.Val.of_list [ ("a", normal foo) ] in + check v; + let v = Inode.Val.of_list [ ("a", normal foo); ("y", node bar) ] in + check v; + let v = + Inode.Val.of_list [ ("x", node foo); ("a", normal foo); ("y", node bar) ] + in + check v; + let v = + Inode.Val.of_list + [ + ("x", normal foo); ("z", normal foo); ("a", normal foo); ("y", node bar); + ] + in + check v; + Context.close t + +let test_concrete_inodes () = + let* () = test_concrete_inodes ~indexing_strategy:`always in + test_concrete_inodes ~indexing_strategy:`minimal + +module Inode_tezos = struct + module S = + Inode_modules (Conf) (Irmin_tezos.Schema) + (struct + let foo = Bytes.make 10 '0' + let bar = Bytes.make 10 '1' + end) + + let encode_bin h v = + let v1 = S.Inter.Val.to_raw v in + S.Inter.Raw.encode_bin + ~dict:(fun _ -> None) + ~offset_of_key:(fun _ -> None) + h v1 + + let hex_encode s = Hex.of_string s |> Hex.show + + let test_encode_bin_values ~indexing_strategy = + rm_dir root; + let* t = S.Context.get_store ~indexing_strategy () in + let { S.Context.foo; _ } = t in + let v = S.Inode.Val.of_list [ ("x", normal foo); ("z", normal foo) ] in + let h = S.Inter.Val.hash_exn v in + let hash_to_bin_string = + Irmin.Type.(unstage (to_bin_string S.Inode.Val.hash_t)) + in + let key_to_bin_string = + Irmin.Type.(unstage (to_bin_string S.Inode.Key.t)) + in + let hex_of_h = h |> hash_to_bin_string |> hex_encode in + let hex_of_foo = foo |> key_to_bin_string |> hex_encode in + let checks = + [ + ("hash", hex_of_h); + ("magic R", hex_encode "R"); + ("data length", "48"); + ("Values", "00"); + ("length", "02"); + ("contents-x-dd", "09"); + ("Direct", "01"); + ("x", "78"); + ("hash of contents", hex_of_foo); + ("contents-x-dd", "09"); + ("Direct", "01"); + ("z", "7a"); + ("hash of contents", hex_of_foo); + ] + in + check_iter "encode_bin" (encode_bin h) v checks; + S.Context.close t + + let test_encode_bin_values () = + let* () = test_encode_bin_values ~indexing_strategy:`always in + test_encode_bin_values ~indexing_strategy:`minimal + + let test_encode_bin_tree ~indexing_strategy = + rm_dir root; + let* t = S.Context.get_store ~indexing_strategy () in + let { S.Context.foo; bar; _ } = t in + let v = + S.Inode.Val.of_list + [ + ("x", normal foo); + ("z", normal foo); + ("y", normal bar); + ("w", normal bar); + ("t", normal bar); + ] + in + let h = S.Inter.Val.hash_exn v in + let to_bin_string_hash = + Irmin.Type.(unstage (to_bin_string S.Inode.Val.hash_t)) + in + let hex_of_h = h |> to_bin_string_hash |> Hex.of_string |> Hex.show in + let checks = + [ + ("hash", hex_of_h); + ("magic R", hex_encode "R"); + ("data length", "48"); + ("Tree", "01"); + ("depth", "00"); + ("nb of leaves", "05"); + ("length of entries", "02"); + ("index", "00"); + ("Direct", "01"); + ( "hash of entry", + "8c81eb0a729858e10a8aed80f4ad638b26e80cf713be980a83620e22516001bf" ); + ("index", "01"); + ("Direct", "01"); + ( "hash of entry", + "461a30b373e7d98e23dc963934a417d7c5aceb14fa2fb6da6950438fd54c9aa9" ); + ] + in + check_iter "encode_bin" (encode_bin h) v checks; + S.Context.close t + + let test_encode_bin_tree () = + let* () = test_encode_bin_tree ~indexing_strategy:`always in + test_encode_bin_tree ~indexing_strategy:`minimal +end + +module Child_ordering = struct + (** Tests of the relative ordering of Inode children (which can be configured + by the user). *) + + module Step = struct + type t = Schema.Path.step [@@deriving irmin ~short_hash] + + module Hash = + Irmin.Hash.Typed + (Schema.Hash) + (struct + type nonrec t = t + + let t = t + end) + + type nonrec hash = Hash.t [@@deriving irmin ~to_bin_string] + + let hash : t -> string = fun s -> hash_to_bin_string (Hash.hash s) + end + + module type S = Irmin_pack.Inode.Child_ordering with type step := Step.t + + let make ?entries:(entries' = Irmin_tezos.Conf.entries) + (t : Irmin_pack.Conf.inode_child_order) : (module S) = + let module Conf = struct + include Irmin_tezos.Conf + + let entries = entries' + let inode_child_order = t + end in + let module T = Inode_modules (Conf) (Schema) (String_contents) in + (module T.Inter.Child_ordering) + + let check_child_index pos (module Order : S) ~expected ~step ~depth = + let msg = + Fmt.str "Short hash of child at { depth = %d; step = %S }" depth step + in + let actual = Order.key step |> Order.index ~depth in + check_int pos ~msg ~expected actual + + let check_max_depth_exception pos (module Order : S) ~step ~depth = + match Order.key step |> Order.index ~depth with + | index -> + Alcotest.failf ~pos + "Expected [Max_depth %d] to be raised, but got a computed index of \ + %d instead" + depth index + | exception Irmin_pack.Inode.Max_depth _ -> () + + (* Get the bit at index [n] in a string: *) + let get_bit str n = + let chosen_byte = Bytes.get_uint8 (Bytes.unsafe_of_string str) (n / 8) in + let bit_index_in_byte = n mod 8 in + (* Selects only the chosen bit from our byte: *) + let mask = 1 lsl (7 - bit_index_in_byte) in + let masked_byte = chosen_byte land mask in + let chosen_bit = masked_byte lsr (7 - bit_index_in_byte) in + assert (chosen_bit = 0 || chosen_bit = 1); + chosen_bit + + let test_seeded_hash _switch () = + let entries = Irmin_tezos.Conf.entries in + let reference ~depth step = + abs (Step.short_hash ~seed:depth step) mod entries + in + let (module Order) = make `Seeded_hash in + + (* Test some hard-coded samples to ensure stablility: *) + check_child_index __POS__ (module Order) ~expected:23 ~step:"a" ~depth:1; + check_child_index __POS__ (module Order) ~expected:2 ~step:"b" ~depth:2; + check_child_index __POS__ (module Order) ~expected:10 ~step:"foo" ~depth:42; + + (* Should match reference implementation for some random samples too: *) + for _ = 1 to 1_000 do + let step = random_string 8 and depth = Random.int 10 in + let expected = reference ~depth step in + check_child_index __POS__ (module Order) ~expected ~step ~depth + done; + Lwt.return_unit + + let hash_bits_max_depth ~log2_entries = + (* For a given [depth], the final bit of the corresponding index is at + * position [log2_entries * depth + log2_entries - 1] in the hash. If this + * is out-of-bounds in the hash, then we expect computing the ordering to + * fail (since we don't use modular indexing of the hash). *) + let rec aux depth = + if log2_entries * (depth + 1) > 8 * Hash.hash_size then depth - 1 + else aux (succ depth) + in + aux 0 + + let test_hash_bits _switch () = + (* [entries] is required to be a power of 2 greater than 1 and less than + 2048, so we test every possible value here: *) + for log2_entries = 1 to 10 do + let entries = 1 lsl log2_entries in + let max_depth = hash_bits_max_depth ~log2_entries in + let (module Order) = make ~entries `Hash_bits in + [%log.app + "Testing hash_bits with { log_entries = %d; entries = %d; max_depth = \ + %d }" + log2_entries entries max_depth]; + + (* Index is computed by reading [log2_entries] consecutive bits from the + hash of the step, starting at the [log2_entries * depth]-th byte. *) + let reference ~depth step = + let hash = Step.hash step in + let index = ref 0 in + for i = 0 to log2_entries - 1 do + let selected_bit = get_bit hash ((log2_entries * depth) + i) in + index := (!index lsl 1) lor selected_bit + done; + !index + in + + for _ = 1 to 100 do + let step = random_string 8 in + (* We compute the valid index for this step at every depth up to + [max_depth]: *) + for depth = 0 to max_depth do + let expected = reference ~depth step in + check_child_index __POS__ (module Order) ~expected ~step ~depth + done; + (* Beyond [max_depth], the index computation should fail: *) + check_max_depth_exception __POS__ + (module Order) + ~step ~depth:(max_depth + 1) + done + done; + Lwt.return_unit + + let test_custom _switch () = + let entries = 16 in + let square_index ~depth step = + let a = depth and b = int_of_string (Bytes.unsafe_to_string step) in + a * b + in + let (module Order) = make ~entries (`Custom square_index) in + check_child_index __POS__ (module Order) ~depth:1 ~step:"1" ~expected:1; + check_child_index __POS__ (module Order) ~depth:2 ~step:"2" ~expected:4; + check_child_index __POS__ (module Order) ~depth:3 ~step:"3" ~expected:9; + (); + Lwt.return_unit +end + +let tests = + let tc_sync name f = Alcotest_lwt.test_case name `Quick f in + let tc name f = tc_sync name (fun _switch -> f) in + (* Test disabled because it relies on being able to serialise concrete inodes, + which is not possible following the introduction of structured keys. *) + let _ = tc "test truncated inodes" test_truncated_inodes in + let _ = tc "test encode bin of trees" Inode_tezos.test_encode_bin_tree in + [ + tc "add values" test_add_values; + tc "add values to inodes" test_add_inodes; + tc "remove values" test_remove_values; + tc "remove inodes" test_remove_inodes; + tc "test concrete inodes" test_concrete_inodes; + tc "test representation uniqueness" + test_representation_uniqueness_maxdepth_3; + tc "test encode bin of values" Inode_tezos.test_encode_bin_values; + tc "test intermediate inode as root" test_intermediate_inode_as_root; + tc_sync "Child_ordering.seeded_hash" Child_ordering.test_seeded_hash; + tc_sync "Child_ordering.hash_bits" Child_ordering.test_hash_bits; + tc_sync "Child_ordering.custom" Child_ordering.test_custom; + ] diff --git a/vendors/irmin/test/irmin-pack/test_inode.mli b/vendors/irmin/test/irmin-pack/test_inode.mli new file mode 100644 index 0000000000000000000000000000000000000000..4acc26805b83290745657bafd214fc23476222e8 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_inode.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val tests : unit Alcotest_lwt.test_case list diff --git a/vendors/irmin/test/irmin-pack/test_pack.ml b/vendors/irmin/test/irmin-pack/test_pack.ml new file mode 100644 index 0000000000000000000000000000000000000000..228d8be3efc8e1d08fc2bcfc02c2cab0f260c33a --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_pack.ml @@ -0,0 +1,514 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +let test_dir = Filename.concat "_build" "test-db-pack" + +module Irmin_pack_store (Config : Irmin_pack.Conf.S) : Irmin_test.Generic_key = +struct + open Irmin_pack_unix.Maker (Config) + + include Make (struct + include Irmin_test.Schema + module Node = Irmin.Node.Generic_key.Make (Hash) (Path) (Metadata) + module Commit_maker = Irmin.Commit.Generic_key.Maker (Info) + module Commit = Commit_maker.Make (Hash) + end) +end + +let suite_pack name_suffix indexing_strategy (module Config : Irmin_pack.Conf.S) + = + let store = (module Irmin_pack_store (Config) : Irmin_test.Generic_key) in + let config = + Irmin_pack.config ~fresh:false ~lru_size:0 ~indexing_strategy test_dir + in + let init ~config = + let test_dir = + Irmin.Backend.Conf.find_root config |> Option.value ~default:test_dir + in + rm_dir test_dir; + Lwt.return_unit + in + let clean = init in + Irmin_test.Suite.create_generic_key ~name:("PACK" ^ name_suffix) + ~import_supported:false ~init ~store ~config ~clean () + +module Irmin_tezos_conf = struct + include Irmin_tezos.Conf + + (* The generic test suite relies a lot on the empty tree. Let's allow it. *) + let forbid_empty_dir_persistence = false +end + +module Irmin_pack_mem_maker : Irmin_test.Generic_key = struct + open Irmin_pack_mem.Maker (Irmin_tezos_conf) + + include Make (struct + include Irmin_test.Schema + module Node = Irmin.Node.Generic_key.Make (Hash) (Path) (Metadata) + module Commit_maker = Irmin.Commit.Generic_key.Maker (Info) + module Commit = Commit_maker.Make (Hash) + end) +end + +let suite_mem = + let store = (module Irmin_pack_mem_maker : Irmin_test.Generic_key) in + let config = Irmin_pack.config ~fresh:false ~lru_size:0 test_dir in + Irmin_test.Suite.create_generic_key ~import_supported:false ~name:"PACK MEM" + ~store ~config () + +let suite = + let module Index = Irmin_pack.Indexing_strategy in + let module Conf_small_nodes = struct + (* Parameters chosen to be different from those in [Irmin_tezos.Conf]: *) + let entries = 2 + let stable_hash = 3 + let contents_length_header = None + let inode_child_order = `Hash_bits + let forbid_empty_dir_persistence = false + end in + [ + suite_pack " { Tezos }" Index.minimal (module Irmin_tezos_conf); + suite_pack " { Small_nodes }" Index.always (module Conf_small_nodes); + suite_mem; + ] + +module Context = Make_context (struct + let root = test_dir +end) + +let flush fm = File_manager.flush fm |> Errs.raise_if_error +let reload fm = File_manager.reload fm |> Errs.raise_if_error + +module Dict = struct + let test_dict () = + let (d : Context.d) = Context.get_dict ~readonly:false ~fresh:true () in + let x1 = Dict.index d.dict "foo" in + Alcotest.(check (option int)) "foo" (Some 0) x1; + let x1 = Dict.index d.dict "foo" in + Alcotest.(check (option int)) "foo" (Some 0) x1; + let x2 = Dict.index d.dict "bar" in + Alcotest.(check (option int)) "bar" (Some 1) x2; + let x3 = Dict.index d.dict "toto" in + Alcotest.(check (option int)) "toto" (Some 2) x3; + let x4 = Dict.index d.dict "titiabc" in + Alcotest.(check (option int)) "titiabc" (Some 3) x4; + let x1 = Dict.index d.dict "foo" in + Alcotest.(check (option int)) "foo" (Some 0) x1; + flush d.fm; + let (d2 : Context.d) = + Context.get_dict ~name:d.name ~readonly:false ~fresh:false () + in + let x4 = Dict.index d2.dict "titiabc" in + Alcotest.(check (option int)) "titiabc" (Some 3) x4; + let v1 = Dict.find d2.dict (get x1) in + Alcotest.(check (option string)) "find x1" (Some "foo") v1; + let v2 = Dict.find d2.dict (get x2) in + Alcotest.(check (option string)) "find x2" (Some "bar") v2; + let v3 = Dict.find d2.dict (get x3) in + Alcotest.(check (option string)) "find x3" (Some "toto") v3; + Context.close_dict d; + let (d3 : Context.d) = + Context.get_dict ~name:d.name ~readonly:false ~fresh:false () + in + let v1 = Dict.find d3.dict (get x1) in + Alcotest.(check (option string)) "find x1" (Some "foo") v1; + Context.close_dict d2; + Context.close_dict d3 + + let ignore_int (_ : int option) = () + + let test_readonly_dict () = + let (d : Context.d) = Context.get_dict ~readonly:false ~fresh:true () in + let (d2 : Context.d) = + Context.get_dict ~name:d.name ~readonly:true ~fresh:false () + in + let check_index k i = + Alcotest.(check (option int)) k (Some i) (Dict.index d2.dict k) + in + let check_find k i = + Alcotest.(check (option string)) k (Some k) (Dict.find d2.dict i) + in + let check_none k i = + Alcotest.(check (option string)) k None (Dict.find d2.dict i) + in + let check_raise k = + try + ignore_int (Dict.index d2.dict k); + Alcotest.fail "RO dict should not be writable" + with Irmin_pack.RO_not_allowed -> () + in + ignore_int (Dict.index d.dict "foo"); + ignore_int (Dict.index d.dict "foo"); + ignore_int (Dict.index d.dict "bar"); + ignore_int (Dict.index d.dict "toto"); + ignore_int (Dict.index d.dict "titiabc"); + ignore_int (Dict.index d.dict "foo"); + flush d.fm; + reload d2.fm; + check_index "titiabc" 3; + check_index "bar" 1; + check_index "toto" 2; + check_find "foo" 0; + check_raise "xxx"; + ignore_int (Dict.index d.dict "hello"); + check_raise "hello"; + check_none "hello" 4; + flush d.fm; + reload d2.fm; + check_find "hello" 4; + Context.close_dict d; + Context.close_dict d2 + + let tests = + [ + Alcotest_lwt.test_case "dict" `Quick (fun _ () -> + Lwt.return (test_dict ())); + Alcotest_lwt.test_case "RO dict" `Quick (fun _ () -> + Lwt.return (test_readonly_dict ())); + ] +end + +module Pack = struct + let test_pack () = + let* t = Context.get_rw_pack () in + let x1 = "foo" in + let x2 = "bar" in + let x3 = "otoo" in + let x4 = "sdadsadas" in + let h1 = sha1_contents x1 in + let h2 = sha1_contents x2 in + let h3 = sha1_contents x3 in + let h4 = sha1_contents x4 in + let* k1, k2, k3, k4 = + Pack.batch t.pack (fun w -> + Lwt_list.map_s + (fun (k, v) -> Pack.unsafe_add w k v) + [ (h1, x1); (h2, x2); (h3, x3); (h4, x4) ]) + >|= function + | [ k1; k2; k3; k4 ] -> (k1, k2, k3, k4) + | _ -> assert false + in + + let test t = + let* y1 = Pack.find t k1 >|= get in + Alcotest.(check string) "x1" x1 y1; + let* y3 = Pack.find t k3 >|= get in + Alcotest.(check string) "x3" x3 y3; + let* y2 = Pack.find t k2 >|= get in + Alcotest.(check string) "x2" x2 y2; + let* y4 = Pack.find t k4 >|= get in + Alcotest.(check string) "x4" x4 y4; + Lwt.return_unit + in + test t.pack >>= fun () -> + let* t' = Context.get_ro_pack t.name in + test t'.pack >>= fun () -> + Context.close_pack t >>= fun () -> Context.close_pack t' + + let test_readonly_pack () = + let* t = Context.get_rw_pack () in + let* t' = Context.get_ro_pack t.name in + let* () = + let adds l = + List.map + (fun (k, v) -> + Pack.unsafe_append ~ensure_unique:true ~overcommit:false t.pack k v) + l + in + let x1 = "foo" in + let x2 = "bar" in + let h1 = sha1_contents x1 in + let h2 = sha1_contents x2 in + let[@warning "-8"] [ _k1; k2 ] = adds [ (h1, x1); (h2, x2) ] in + let* y2 = Pack.find t'.pack k2 in + Alcotest.(check (option string)) "before reload" None y2; + flush t.fm; + reload t'.fm; + let* y2 = Pack.find t'.pack k2 in + Alcotest.(check (option string)) "after reload" (Some x2) y2; + let x3 = "otoo" in + let x4 = "sdadsadas" in + let h3 = sha1_contents x3 in + let h4 = sha1_contents x4 in + let[@warning "-8"] [ k3; _k4 ] = adds [ (h3, x3); (h4, x4) ] in + flush t.fm; + reload t'.fm; + let* y2 = Pack.find t'.pack k2 in + Alcotest.(check (option string)) "y2" (Some x2) y2; + let* y3 = Pack.find t'.pack k3 in + Alcotest.(check (option string)) "y3" (Some x3) y3; + Lwt.return_unit + in + Context.close_pack t >>= fun () -> Context.close_pack t' + + let test_close_pack_more () = + (*open and close in rw*) + let* t = Context.get_rw_pack () in + let x1 = "foo" in + let h1 = sha1_contents x1 in + let k1 = + Pack.unsafe_append ~ensure_unique:true ~overcommit:false t.pack h1 x1 + in + flush t.fm; + Context.close_pack t >>= fun () -> + (*open and close in ro*) + let* t1 = Context.get_ro_pack t.name in + let* y1 = Pack.find t1.pack k1 >|= get in + Alcotest.(check string) "x1.1" x1 y1; + Context.close_pack t1 >>= fun () -> + (* reopen in rw *) + let* t2 = Context.reopen_rw t.name in + let* y1 = Pack.find t2.pack k1 >|= get in + Alcotest.(check string) "x1.2" x1 y1; + (*reopen in ro *) + let* t3 = Context.get_ro_pack t.name in + let* y1 = Pack.find t3.pack k1 >|= get in + Alcotest.(check string) "x1.3" x1 y1; + Context.close_pack t2 >>= fun () -> Context.close_pack t3 + + let test_close_pack () = + let* t = Context.get_rw_pack () in + let w = t.pack in + let x1 = "foo" in + let x2 = "bar" in + let h1 = sha1_contents x1 in + let h2 = sha1_contents x2 in + let* k1, k2 = + Pack.batch w (fun w -> + Lwt_list.map_s + (fun (k, v) -> Pack.unsafe_add w k v) + [ (h1, x1); (h2, x2) ]) + >|= function + | [ k1; k2 ] -> (k1, k2) + | _ -> assert false + in + Context.close_pack t >>= fun () -> + (*reopen in rw *) + let* t' = Context.reopen_rw t.name in + let* y2 = Pack.find t'.pack k2 >|= get in + Alcotest.(check string) "x2.1" x2 y2; + let* y1 = Pack.find t'.pack k1 >|= get in + Alcotest.(check string) "x1.1" x1 y1; + let x3 = "toto" in + let h3 = sha1_contents x3 in + let k3 = + Pack.unsafe_append ~ensure_unique:true ~overcommit:false t'.pack h3 x3 + in + Context.close_pack t' >>= fun () -> + (*reopen in rw *) + let* t2 = Context.reopen_rw t.name in + let* y2 = Pack.find t2.pack k2 >|= get in + Alcotest.(check string) "x2.2" x2 y2; + let* y3 = Pack.find t2.pack k3 >|= get in + Alcotest.(check string) "x3.2" x3 y3; + let* y1 = Pack.find t2.pack k1 >|= get in + Alcotest.(check string) "x1.2" x1 y1; + Context.close_pack t2 >>= fun () -> + (*reopen in ro *) + let* t' = Context.get_ro_pack t.name in + let* y1 = Pack.find t'.pack k1 >|= get in + Alcotest.(check string) "x1.3" x1 y1; + let* y2 = Pack.find t'.pack k2 >|= get in + Alcotest.(check string) "x2.3" x2 y2; + Context.close_pack t' >>= fun () -> Lwt.return_unit + + (** Index can be flushed to disk independently of pack, we simulate this in + the tests using [Index.filter] and [Index.flush]. Regression test for PR + 1008 in which values were indexed before being reachable in pack. *) + let readonly_reload_index_flush () = + let* t = Context.get_rw_pack () in + let* t' = Context.get_ro_pack t.name in + let test w = + let x1 = "foo" in + let h1 = sha1_contents x1 in + let k1 = + Pack.unsafe_append ~ensure_unique:true ~overcommit:false w h1 x1 + in + reload t'.fm; + let* y1 = Pack.find t'.pack k1 in + Alcotest.(check (option string)) "reload before filter" None y1; + Index.filter t.index (fun _ -> true); + reload t'.fm; + let* y1 = Pack.find t'.pack k1 in + Alcotest.(check (option string)) "reload after filter" (Some x1) y1; + let x2 = "foo" in + let h2 = sha1_contents x2 in + let k2 = + Pack.unsafe_append ~ensure_unique:true ~overcommit:false w h2 x2 + in + Index.flush t.index ~with_fsync:false |> Errs.raise_if_error; + let+ y2 = Pack.find t'.pack k2 in + Alcotest.(check (option string)) "reload after flush" (Some x2) y2 + in + test t.pack >>= fun () -> + Context.close_pack t >>= fun () -> Context.close_pack t' + + let readonly_find_index_flush () = + let* t = Context.get_rw_pack () in + let* t' = Context.get_ro_pack t.name in + let check h x msg = + let+ y = Pack.find t'.pack h in + Alcotest.(check (option string)) msg (Some x) y + in + let test w = + let x1 = "foo" in + let h1 = sha1_contents x1 in + let k1 = + Pack.unsafe_append ~ensure_unique:true ~overcommit:false w h1 x1 + in + flush t.fm; + reload t'.fm; + check k1 x1 "find before filter" >>= fun () -> + Index.filter t.index (fun _ -> true); + check k1 x1 "find after filter" >>= fun () -> + let x2 = "bar" in + let h2 = sha1_contents x2 in + let k2 = + Pack.unsafe_append ~ensure_unique:true ~overcommit:false w h2 x2 + in + flush t.fm; + reload t'.fm; + check k2 x2 "find before flush" >>= fun () -> + let x3 = "toto" in + let h3 = sha1_contents x3 in + let k3 = + Pack.unsafe_append ~ensure_unique:true ~overcommit:false w h3 x3 + in + Index.flush t.index ~with_fsync:false |> Errs.raise_if_error; + check k2 x2 "find after flush" >>= fun () -> + flush t.fm; + reload t'.fm; + check k3 x3 "find after flush new values" + in + test t.pack >>= fun () -> + Context.close_pack t >>= fun () -> Context.close_pack t' + + let tests = + [ + Alcotest_lwt.test_case "pack" `Quick (fun _switch () -> test_pack ()); + Alcotest_lwt.test_case "RO pack" `Quick (fun _switch () -> + test_readonly_pack ()); + Alcotest_lwt.test_case "close" `Quick (fun _switch () -> + test_close_pack ()); + Alcotest_lwt.test_case "close readonly" `Quick (fun _switch () -> + test_close_pack_more ()); + Alcotest_lwt.test_case "readonly reload, index flush" `Quick + (fun _switch () -> readonly_reload_index_flush ()); + Alcotest_lwt.test_case "readonly find, index flush" `Quick + (fun _switch () -> readonly_find_index_flush ()); + ] +end + +module Branch = struct + module Branch = + Irmin_pack_unix.Atomic_write.Make_persistent + (Irmin.Branch.String) + (Irmin_pack.Atomic_write.Value.Of_hash (Irmin.Hash.SHA1)) + + let pp_hash = Irmin.Type.pp Irmin.Hash.SHA1.t + + let test_branch () = + let branches = [ "foo"; "bar/toto"; "titi" ] in + let test t = + Lwt_list.iter_s (fun k -> Branch.set t k (sha1 k)) branches >>= fun () -> + let check h = + let+ v = Branch.find t h in + Alcotest.(check (option hash)) h (Some (sha1 h)) v + in + Lwt_list.iter_p check branches + in + let name = Context.fresh_name "branch" in + Branch.v ~fresh:true name >>= test >>= fun () -> + Branch.v ~fresh:true name >>= test >>= fun () -> + Branch.v ~fresh:true name >>= test >>= fun () -> + let* t = Branch.v ~fresh:false name in + test t >>= fun () -> + let x = sha1 "XXX" in + Branch.set t "foo" x >>= fun () -> + let* t = Branch.v ~fresh:false name in + let* v = Branch.find t "foo" in + Alcotest.(check (option hash)) "foo" (Some x) v; + let* br = Branch.list t in + Alcotest.(check (slist string compare)) "branches" branches br; + Branch.remove t "foo" >>= fun () -> + let* t = Branch.v ~fresh:false name in + let* v = Branch.find t "foo" in + Alcotest.(check (option hash)) "foo none" None v; + let* br = Branch.list t in + Alcotest.(check (slist string compare)) + "branches" + (List.filter (( <> ) "foo") branches) + br; + Lwt.return_unit + + let test_close_branch () = + let branches = [ "foo"; "bar/toto"; "titi" ] in + let add t = + Lwt_list.iter_s + (fun k -> + [%logs.debug "k = %s, v= %a" k pp_hash (sha1 k)]; + Branch.set t k (sha1 k)) + branches + in + let test t = + let check h = + let+ v = Branch.find t h in + Alcotest.(check (option hash)) h (Some (sha1 h)) v + in + Lwt_list.iter_p check branches + in + let name = Context.fresh_name "branch" in + let* t = Branch.v ~fresh:true name in + add t >>= fun () -> + test t >>= fun () -> + Branch.close t >>= fun () -> + let* t = Branch.v ~fresh:false ~readonly:true name in + test t >>= fun () -> + Branch.close t >>= fun () -> + let name = Context.fresh_name "branch" in + let* t1 = Branch.v ~fresh:true ~readonly:false name in + let* t2 = Branch.v ~fresh:false ~readonly:true name in + add t1 >>= fun () -> + Branch.close t1 >>= fun () -> test t2 + + let tests = + [ + Alcotest_lwt.test_case "branch" `Quick (fun _switch -> test_branch); + Alcotest_lwt.test_case "branch close" `Quick (fun _switch -> + test_close_branch); + ] +end + +let misc = + [ + ("hashes", Test_hashes.tests); + ("dict-files", Dict.tests); + ("pack-files", Pack.tests); + ("branch-files", Branch.tests); + ("instances", Multiple_instances.tests); + ("existing stores", Test_existing_stores.tests); + ("inodes", Test_inode.tests); + ("trees", Test_tree.tests); + ("version-bump", Test_pack_version_bump.tests); + ("snapshot", Test_snapshot.tests); + ("upgrade", Test_upgrade.tests); + ("blocking gc", Test_gc.Blocking_gc.tests); + ("concurrent gc", Test_gc.Concurrent_gc.tests); + ("flush", Test_flush_reload.tests); + ] diff --git a/vendors/irmin/test/irmin-pack/test_pack.mli b/vendors/irmin/test/irmin-pack/test_pack.mli new file mode 100644 index 0000000000000000000000000000000000000000..599c43edf13de2244ffbb7c77029cade01aacef1 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_pack.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val suite : Irmin_test.Suite.t list +val misc : (string * unit Alcotest_lwt.test_case list) list diff --git a/vendors/irmin/test/irmin-pack/test_pack_version_bump.ml b/vendors/irmin/test/irmin-pack/test_pack_version_bump.ml new file mode 100644 index 0000000000000000000000000000000000000000..17cb1519f5ffcb4dda4c37684f14155f12244d5d --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_pack_version_bump.ml @@ -0,0 +1,164 @@ +(** These tests for issue #1658, which follows PR #1655 which introduces a store + version bump from V1 to V2 when a writer instance adds a V2-only pack entry + (including nodes and commits, but not contents). *) + +open! Import +open Common + +(** {2 Preamble} *) + +let src = Logs.Src.create "tests.version_bump" ~doc:"Test pack version bump" + +module Log = (val Logs.src_log src : Logs.LOG) + +(** Set up modules to allow access to "version_1" store *) +module Private = struct + (* The behaviour under test is independent of which [Conf] we pick: *) + module Conf = Irmin_tezos.Conf + + (* Note: the existing stores use a different hash from [Irmin_tezos.Schema] + (SHA1 rather than BLAKE2b) *) + module Schema = Common.Schema + + (* from test_existing_stores.ml; the V2 is because + test_existing_stores defines two different configs *) + module V2_maker = Irmin_pack_unix.Maker (Conf) + module V2 = V2_maker.Make (Schema) + + (* the following modules are necessary to expose the File_manager.*) + module Index = Irmin_pack_unix.Index.Make (Schema.Hash) + module Io = Irmin_pack_unix.Io.Unix + module Errs = Irmin_pack_unix.Io_errors.Make (Io) + module Control = Irmin_pack_unix.Control_file.Make (Io) + module Aof = Irmin_pack_unix.Append_only_file.Make (Io) + + module File_manager = + Irmin_pack_unix.File_manager.Make (Control) (Aof) (Aof) (Index) (Errs) +end + +module Util = struct + (** Following are generic utils *) + + let exec_cmd = Common.exec_cmd + let ( / ) = Filename.concat + let tmp_dir () = Filename.temp_file "test_pack_version_bump_" "" + + (** Copy src to dst; dst is assumed to not exist *) + let copy_dir src dst = + assert (not (Sys.file_exists dst)); + (* don't check if it is empty; perhaps we should *) + Filename.quote_command "cp" [ "-R"; src; dst ] |> fun cmd -> + exec_cmd cmd |> function + | Ok () -> () + | Error n -> + Fmt.failwith + "Failed to set up test env; command `%s' exited with non-zero code %d\n" + cmd n + + (** Identify the root directory, by comparing st_dev,st_ino *) + let is_root = + let open Unix in + let root_stat = stat "/" in + fun s -> + let stat = Unix.stat s in + (stat.st_dev, stat.st_ino) = (root_stat.st_dev, root_stat.st_ino) + + (** Starting from ".", try to find a parent directory that has a given + property. *) + let find_parent_matching test = + let rec go path = + match test path with + | true -> Ok path + | false -> ( + match is_root path with + | true -> Error () + | false -> go (path / Filename.parent_dir_name)) + in + go Filename.current_dir_name + + (** More specific utils from here *) + + let v1_store_archive_dir = "test" / "irmin-pack" / "data" / "version_1" + + (** Find the project root, that contains the v1_store_archive_dir *) + let project_root () = + find_parent_matching (fun d -> Sys.file_exists (d / v1_store_archive_dir)) + |> function + | Ok s -> s + | Error () -> + Fmt.failwith + "Couldn't find project root containing path to %s, after examining \ + current directory %s and ancestors" + v1_store_archive_dir (Sys.getcwd ()) + + module Unix_ = Irmin_pack_unix.Io_legacy.Unix + + (** Get the version of the underlying file; file is assumed to exist; file is + assumed to be an Irmin_pack.IO.Unix file *) + let io_get_version ~root : [ `V1 | `V2 | `V3 ] = + File_manager.version ~root |> Errs.raise_if_error + + let alco_check_version ~pos ~expected ~actual = + Alcotest.check_repr ~pos Irmin_pack.Version.t "" expected actual +end + +open Util + +(** This sets up infrastructure to open the existing "version_1" store *) +module With_existing_store () = struct + let tmp_dir = tmp_dir () + let () = [%log.info "Using temporary directory %s" tmp_dir] + + (* Make a copy of the v1_store_archive_dir in tmp_dir *) + let () = + rm_dir tmp_dir; + copy_dir (project_root () / v1_store_archive_dir) tmp_dir; + () + + (* [S] is the functionality we use from Private, together with an + appropriate config *) + module S = Private.V2 + + (* Code copied and modified from test_existing_stores.ml; this is + the config for index and pack *) + let config ~readonly : Irmin.config = + Irmin_pack.config ~readonly ~index_log_size:1000 ~fresh:false tmp_dir +end + +(** {2 The tests} *) + +(** Cannot open a V1 store in RO mode. *) +let test_RO_no_migration () : unit Lwt.t = + [%log.info "Executing test_RO_no_migration"]; + let open With_existing_store () in + assert (io_get_version ~root:tmp_dir = `V1); + + let* () = + Alcotest.check_raises_lwt "open V1 store in RO" + (Irmin_pack_unix.Errors.Pack_error `Migration_needed) (fun () -> + let* repo = S.Repo.v (config ~readonly:true) in + S.Repo.close repo) + in + (* maybe the version bump is only visible after, check again *) + alco_check_version ~pos:__POS__ ~expected:`V1 + ~actual:(io_get_version ~root:tmp_dir); + Lwt.return () + +(** Open a V1 store RW mode. Even if no writes, the store migrates to V3. *) +let test_open_RW () : unit Lwt.t = + [%log.info "Executing test_open_RW"]; + let open With_existing_store () in + assert (io_get_version ~root:tmp_dir = `V1); + let* repo = S.Repo.v (config ~readonly:false) in + let* () = S.Repo.close repo in + alco_check_version ~pos:__POS__ ~expected:`V3 + ~actual:(io_get_version ~root:tmp_dir); + Lwt.return () + +let tests = + let f g _switch () = g () in + Alcotest_lwt. + [ + test_case "test_RO_no_migration" `Quick (f test_RO_no_migration); + test_case "test_open_RW" `Quick (f test_open_RW); + ] diff --git a/vendors/irmin/test/irmin-pack/test_pack_version_bump.mli b/vendors/irmin/test/irmin-pack/test_pack_version_bump.mli new file mode 100644 index 0000000000000000000000000000000000000000..01604e1617a5d48f1711e3301f265bac01d878a3 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_pack_version_bump.mli @@ -0,0 +1 @@ +val tests : unit Alcotest_lwt.test_case list diff --git a/vendors/irmin/test/irmin-pack/test_snapshot.ml b/vendors/irmin/test/irmin-pack/test_snapshot.ml new file mode 100644 index 0000000000000000000000000000000000000000..f0cb79b1c620f1f5ca37b110d71f11373608749c --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_snapshot.ml @@ -0,0 +1,262 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +let root_export = Filename.concat "_build" "test-snapshot-export" +let root_import = Filename.concat "_build" "test-snapshot-import" +let src = Logs.Src.create "tests.snapshot" ~doc:"Tests" + +module Log = (val Logs.src_log src : Logs.LOG) + +module S = struct + module Maker = Irmin_pack_unix.Maker (Conf) + include Maker.Make (Schema) +end + +let check_key = Alcotest.check_repr Key.t + +let config ?(readonly = false) ?(fresh = true) ~indexing_strategy root = + Irmin_pack.config ~readonly ?index_log_size ~fresh ~indexing_strategy root + +let info = S.Info.empty + +let read_string rbuf ~len = + let buf, ofs = !rbuf in + if String.length buf - ofs < len then failwith "small buffer" + else + let res = String.sub buf ofs len in + rbuf := (buf, ofs + len); + res + +let set_int8 buf i = + let b = Bytes.create 1 in + Bytes.set_int8 b 0 i; + Buffer.add_bytes buf b + +let get_int8 rbuf = + let string = read_string ~len:1 rbuf in + Bytes.get_int8 (Bytes.of_string string) 0 + +let read_mbytes rbuf b = + let string = read_string rbuf ~len:(Bytes.length b) in + Bytes.blit_string string 0 b 0 (Bytes.length b) + +let encode_bin_snapshot = Irmin.Type.(unstage (encode_bin S.Snapshot.t)) +let decode_bin_snapshot = Irmin.Type.(unstage (decode_bin S.Snapshot.t)) + +let encode_with_size buf snapshot_inode = + let size = ref 0 in + let tmp = Buffer.create 0 in + encode_bin_snapshot snapshot_inode (fun x -> + size := !size + String.length x; + Buffer.add_string tmp x); + set_int8 buf !size; + Buffer.add_buffer buf tmp; + Lwt.return_unit + +let decode_with_size rbuf = + let size = get_int8 rbuf in + let b = Bytes.create size in + let () = read_mbytes rbuf b in + let b = Bytes.to_string b in + decode_bin_snapshot b (ref 0) + +let restore repo ?on_disk buf = + let on_disk = (on_disk :> [ `Path of string | `Reuse ] option) in + let snapshot = S.Snapshot.Import.v ?on_disk repo in + let total = String.length buf in + let total_visited = ref 0 in + let rbuf = ref (buf, 0) in + let rec aux last_key = + let _, read = !rbuf in + if read < total then ( + incr total_visited; + let elt = decode_with_size rbuf in + let* key = S.Snapshot.Import.save_elt snapshot elt in + aux (Some key)) + else Lwt.return (!total_visited, last_key) + in + let* result = aux None in + S.Snapshot.Import.close snapshot repo; + Lwt.return result + +let test ~repo_export ~repo_import ?on_disk tree expected_visited = + let* commit = S.Commit.v repo_export ~parents:[] ~info tree in + let tree = S.Commit.tree commit in + let root_key = S.Tree.key tree |> Option.get in + let buf = Buffer.create 0 in + let* total_visited = + S.Snapshot.export ?on_disk repo_export (encode_with_size buf) ~root_key + in + Alcotest.(check int) + "total visited during export" expected_visited total_visited; + let* total_visited, key = + Buffer.contents buf |> restore repo_import ?on_disk + in + Alcotest.(check int) + "total visited during import" expected_visited total_visited; + let () = + match (root_key, key) with + | _, None -> Alcotest.fail "No key imported" + | `Node key, Some key' -> check_key "snapshot key" key key' + | `Contents _, _ -> Alcotest.fail "Root key should not be contents" + in + Lwt.return_unit + +let tree2 () = + let t = S.Tree.singleton [ "a" ] "x" in + let* t = S.Tree.add t [ "b" ] "y" in + let* t = S.Tree.add t [ "c" ] "y" in + S.Tree.add t [ "d" ] "y" + +let test_in_memory ~indexing_strategy () = + rm_dir root_export; + rm_dir root_import; + let* repo_export = + S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) + in + let* repo_import = + S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) + in + let test = test ~repo_export ~repo_import in + let tree1 = S.Tree.singleton [ "a" ] "x" in + let* () = test tree1 2 in + let* tree2 = tree2 () in + let* () = test tree2 3 in + let* () = S.Repo.close repo_export in + S.Repo.close repo_import + +let test_in_memory_minimal = + test_in_memory ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal + +let test_in_memory_always = + test_in_memory ~indexing_strategy:Irmin_pack.Indexing_strategy.always + +let test_on_disk ~indexing_strategy () = + rm_dir root_export; + rm_dir root_import; + let index_on_disk = Filename.concat root_import "index_on_disk" in + let* repo_export = + S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) + in + let* repo_import = + S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) + in + let test = test ~repo_export ~repo_import in + let* tree2 = tree2 () in + let* () = test ~on_disk:(`Path index_on_disk) tree2 3 in + let* () = S.Repo.close repo_export in + S.Repo.close repo_import + +let test_on_disk_minimal = + test_on_disk ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal + +let test_on_disk_always = + test_on_disk ~indexing_strategy:Irmin_pack.Indexing_strategy.always + +let start_gc repo commit = + let commit_key = S.Commit.key commit in + let* launched = S.start_gc ~unlink:false ~throttle:`Block repo commit_key in + assert launched; + Lwt.return_unit + +let finalise_gc repo = + let* wait = S.finalise_gc ~wait:true repo in + assert wait; + Lwt.return_unit + +let test_gc ~repo_export ~repo_import ?on_disk expected_visited = + (* create the store *) + let* tree1 = + let t = S.Tree.singleton [ "b"; "a" ] "x0" in + S.Tree.add t [ "a"; "b" ] "x1" + in + let* c1 = S.Commit.v repo_export ~parents:[] ~info tree1 in + let k1 = S.Commit.key c1 in + let* tree2 = S.Tree.add tree1 [ "a"; "c" ] "x2" in + let* _ = S.Commit.v repo_export ~parents:[ k1 ] ~info tree2 in + let* tree3 = + let* t = S.Tree.remove tree1 [ "a"; "b" ] in + S.Tree.add t [ "a"; "d" ] "x3" + in + let* c3 = S.Commit.v repo_export ~parents:[ k1 ] ~info tree3 in + (* call gc on last commit *) + let* () = start_gc repo_export c3 in + let* () = finalise_gc repo_export in + let tree = S.Commit.tree c3 in + let root_key = S.Tree.key tree |> Option.get in + let buf = Buffer.create 0 in + let* total_visited = + S.Snapshot.export ?on_disk repo_export (encode_with_size buf) ~root_key + in + Alcotest.(check int) + "total visited during export" expected_visited total_visited; + let* total_visited, key = + Buffer.contents buf |> restore repo_import ?on_disk + in + Alcotest.(check int) + "total visited during import" expected_visited total_visited; + let () = + match (root_key, key) with + | _, None -> Alcotest.fail "No key imported" + | `Node key, Some key' -> check_key "snapshot key" key key' + | `Contents _, _ -> Alcotest.fail "Root key should not be contents" + in + Lwt.return_unit + +let indexing_strategy = Irmin_pack.Indexing_strategy.minimal + +let test_gced_store_in_memory () = + rm_dir root_export; + rm_dir root_import; + let* repo_export = + S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) + in + let* repo_import = + S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) + in + let* () = test_gc ~repo_export ~repo_import 5 in + let* () = S.Repo.close repo_export in + S.Repo.close repo_import + +let test_gced_store_on_disk () = + rm_dir root_export; + rm_dir root_import; + let index_on_disk = Filename.concat root_import "index_on_disk" in + let* repo_export = + S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_export) + in + let* repo_import = + S.Repo.v (config ~readonly:false ~fresh:true ~indexing_strategy root_import) + in + let* () = + test_gc ~repo_export ~repo_import ~on_disk:(`Path index_on_disk) 5 + in + let* () = S.Repo.close repo_export in + S.Repo.close repo_import + +let tests = + let tc name f = Alcotest_lwt.test_case name `Quick (fun _switch () -> f ()) in + [ + tc "in memory minimal" test_in_memory_minimal; + tc "in memory always" test_in_memory_always; + tc "on disk minimal" test_on_disk_minimal; + tc "on disk always" test_on_disk_always; + tc "gced store, in memory" test_gced_store_in_memory; + tc "gced store, on disk" test_gced_store_on_disk; + ] diff --git a/vendors/irmin/test/irmin-pack/test_tree.ml b/vendors/irmin/test/irmin-pack/test_tree.ml new file mode 100644 index 0000000000000000000000000000000000000000..42ecbf3d93f1c0683bbc54ee7586be0873185032 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_tree.ml @@ -0,0 +1,721 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +let root = Filename.concat "_build" "test-tree" +let src = Logs.Src.create "tests.tree" ~doc:"Tests" + +module Log = (val Logs.src_log src : Logs.LOG) +module Hash = Irmin.Hash.SHA1 + +type ('key, 'value) op = + | Add of 'key * 'value + | Del of 'key + | Find of 'key + | Find_tree of 'key + +module Make (Conf : Irmin_pack.Conf.S) = struct + module Store = struct + module Maker = Irmin_pack_unix.Maker (Conf) + include Maker.Make (Schema) + end + + let config ?(readonly = false) ?(fresh = true) root = + Irmin_pack.config ~readonly ?index_log_size ~fresh root + + let info () = Store.Info.empty + + module Tree = Store.Tree + + type context = { repo : Store.repo; tree : Store.tree } + + let export_tree_to_store tree = + let* repo = Store.Repo.v (config ~fresh:true root) in + let* store = Store.empty repo in + let* () = Store.set_tree_exn ~info store [] tree in + let+ tree = Store.tree store in + { repo; tree } + + let close { repo; _ } = Store.Repo.close repo + + let fold ~order t ~init ~f = + Tree.fold ~order ~force:`True ~cache:false ~uniq:`False + ~contents:(fun k _v acc -> if k = [] then Lwt.return acc else f k acc) + t init + + let init_bindings n = + let zero = String.make 10 '0' in + List.init n (fun n -> + let h = Store.Contents.hash (string_of_int n) in + let h = Irmin.Type.to_string Store.Hash.t h in + ([ h ], zero)) + + let init_tree bindings = + let tree = Tree.empty () in + let* tree = + Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + in + export_tree_to_store tree + + let find_tree tree k = + let+ t = Tree.find_tree tree k in + match t with None -> tree | Some t -> t + + let find tree k = + let+ _ = Tree.find tree k in + tree + + let run_one tree = function + | Add (k, v) -> Tree.add tree k v + | Del k -> Tree.remove tree k + | Find k -> find tree k + | Find_tree k -> find_tree tree k + + let run ops tree = + let run_one op = + let* _ = run_one tree op in + Lwt.return_unit + in + let+ () = Lwt_list.iter_s run_one ops in + (tree, ()) + + let proof_of_ops repo hash ops : _ Lwt.t = + let+ t, () = Store.Tree.produce_proof repo hash (run ops) in + t + + let stream_of_ops repo hash ops : _ Lwt.t = + let+ t, () = Store.Tree.produce_stream repo hash (run ops) in + t + + let tree_proof_t = Tree.Proof.t Tree.Proof.tree_t + let stream_proof_t = Tree.Proof.t Tree.Proof.stream_t + let bin_of_proof = Irmin.Type.(unstage (to_bin_string tree_proof_t)) + let proof_of_bin = Irmin.Type.(unstage (of_bin_string tree_proof_t)) + let bin_of_stream = Irmin.Type.(unstage (to_bin_string stream_proof_t)) +end + +module Default = Make (Conf) +open Default + +type bindings = string list list [@@deriving irmin] + +let equal_ordered_slist ~msg l1 l2 = Alcotest.check_repr bindings_t msg l1 l2 + +let fold ~order ~force t ~init ~f = + Tree.fold ~order ~force ~cache:false ~uniq:`False + ~contents:(fun k _v acc -> if k = [] then Lwt.return acc else f k acc) + t init + +let equal_slist ~msg l1 l2 = + Alcotest.(check (slist (list string) Stdlib.compare)) msg l1 l2 + +let steps = + ["00"; "01"; "02"; "03"; "05"; "06"; "07"; "09"; "0a"; "0b"; "0c"; + "0e"; "0f"; "10"; "11"; "12"; "13"; "14"; "15"; "16"; "17"; "19"; + "1a"; "1b"; "1c"; "1d"; "1e"; "1f"; "20"; "22"; "23"; "25"; "26"; + "27"; "28"; "2a"; "2b"; "2f"; "30"; "31"; "32"; "33"; "35"; "36"; + "37"; "3a"; "3b"; "3c"; "3d"; "3e"; "3f"; "40"; "42"; "43"; "45"; + "46"; "47"; "48"; "4a"; "4b"; "4c"; "4e"; "4f"; "50"; "52"; "53"; + "54"; "55"; "56"; "57"; "59"; "5b"; "5c"; "5f"; "60"; "61"; "62"; + "63"; "64"; "65"; "66"; "67"; "69"; "6b"; "6c"; "6d"; "6e"; "6f"; + "71"; "72"; "73"; "74"; "75"; "78"; "79"; "7a"; "7b"; "7c"; "7d"; + "7e"; "80"; "82"; "83"; "84"; "85"; "86"; "88"; "8b"; "8c"; "8d"; + "8f"; "92"; "93"; "94"; "96"; "97"; "99"; "9a"; "9b"; "9d"; "9e"; + "9f"; "a0"; "a1"; "a2"; "a3"; "a4"; "a5"; "a6"; "a7"; "a8"; "aa"; + "ab"; "ac"; "ad"; "ae"; "af"; "b0"; "b1"; "b2"; "b3"; "b4"; "b6"; + "b8"; "b9"; "bb"; "bc"; "bf"; "c0"; "c1"; "c2"; "c3"; "c4"; "c5"; + "c8"; "c9"; "cb"; "cc"; "cd"; "ce"; "d0"; "d1"; "d2"; "d4"; "d5"; + "d7"; "d8"; "d9"; "da"; "e0"; "e3"; "e6"; "e8"; "e9"; "ea"; "ec"; + "ee"; "ef"; "f0"; "f1"; "f5"; "f7"; "f8"; "f9"; "fb"; "fc"; "fd"; + "fe"; "ff"; "g0"; "g1"; "g2"; "g3"; "g4"; "g5"; "g6"; "g7"; "g8"; + "h0"; "h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "h7"; "h8"; "h9"; "ha"; + "i0"; "i1"; "i2"; "i3"; "i4"; "i5"; "i6"; "i7"; "i8"; "i9"; "ia"; + "j0"; "j1"; "j2"; "j3"; "j4"; "j5"; "j6"; "j7"; "j8"; "j9"; "ja"; + "k0"; "k1"; "k2"; "k3"; "k4"; "k5"; "k6"; "k7"; "k8"; "k9"; "ka"; + "l0"; "l1"; "l2"; "l3"; "l4"; "l5"; "l6"; "l7"; "l8"; "l9"; "la"; + "m0"; "m1"; "m2"; "m3"; "m4"; "m5"; "m6"; "m7"; "m8"; "m9"; "ma"; + "n0"; "n1"; "n2"; "n3"; "n4"; "n5"; "n6"; "n7"; "n8"; "n9"; "na"; + "p0"; "p1"; "p2"; "p3"; "p4"; "p5"; "p6"; "p7"; "p8"; "p9"; "pa"; + "q0"; "q1"; "q2"; "q3"; "q4"; "q5"; "q6"; "q7"; "q8"; "q9"; "qa"; + "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r8"; "r9"; "ra";] +[@@ocamlformat "disable"] + +let version = + let version = Sys.ocaml_version in + Char.code version.[0] - 48 + +let some_steps = [ "0g"; "1g"; "0h"; "2g"; "1h"; "2h" ] + +let some_random_steps = + if version >= 5 then + [ [ "1g" ]; [ "0h" ]; [ "2h" ]; [ "1h" ]; [ "2g" ]; [ "0g" ] ] + else [ [ "2g" ]; [ "1h" ]; [ "0h" ]; [ "2h" ]; [ "0g" ]; [ "1g" ] ] + +let another_random_steps = + if version >= 5 then + [ [ "0g" ]; [ "0h" ]; [ "1h" ]; [ "2h" ]; [ "2g" ]; [ "1g" ] ] + else [ [ "1g" ]; [ "2h" ]; [ "1h" ]; [ "0g" ]; [ "0h" ]; [ "2g" ] ] + +let zero = String.make 10 '0' +let bindings steps = List.map (fun x -> ([ x ], zero)) steps + +let test_fold ?export_tree_to_store:(export_tree_to_store' = true) ~order + bindings expected = + let tree = Tree.empty () in + let* tree = + Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + in + let* close = + match export_tree_to_store' with + | true -> + let+ ctxt = export_tree_to_store tree in + fun () -> close ctxt + | false -> Lwt.return Lwt.return + in + let* keys = + fold + ~force: + (if export_tree_to_store' then `True else `False (Fun.const Lwt.return)) + ~order tree ~init:[] + ~f:(fun k acc -> Lwt.return (k :: acc)) + in + let keys = List.rev keys in + let msg, equal_lists = + match order with + | `Sorted -> ("sorted", equal_ordered_slist) + | `Random _ -> ("random", equal_ordered_slist) + | `Undefined -> ("undefined", equal_slist) + in + equal_lists ~msg:(Fmt.str "Visit elements in %s order" msg) expected keys; + close () + +let test_fold_sorted () = + let bindings = bindings steps in + let expected = List.map fst bindings in + test_fold ~order:`Sorted bindings expected + +let test_fold_random () = + let bindings = bindings some_steps in + let state = Random.State.make [| 0 |] in + let* () = test_fold ~order:(`Random state) bindings some_random_steps in + let state = Random.State.make [| 1 |] in + let* () = test_fold ~order:(`Random state) bindings another_random_steps in + + (* Random fold order should still be respected if [~force:`False]. This is a + regression test for a bug in which the fold order of in-memory nodes during + a non-forcing traversal was always sorted. *) + let state = Random.State.make [| 1 |] in + let* () = + test_fold ~order:(`Random state) ~export_tree_to_store:false bindings + another_random_steps + in + + Lwt.return_unit + +let test_fold_undefined () = + let bindings = bindings steps in + let expected = List.map fst bindings in + test_fold ~order:`Undefined bindings expected + +let proof_of_bin s = + match proof_of_bin s with Ok s -> s | Error (`Msg e) -> Alcotest.fail e + +let check_equivalence tree proof op = + match op with + | Add (k, v) -> + let* tree = Tree.add tree k v in + let+ proof = Tree.add proof k v in + Alcotest.(check_repr Store.Hash.t) + (Fmt.str "same hash add %a" Fmt.(Dump.list string) k) + (Tree.hash tree) (Tree.hash proof); + (tree, proof) + | Del k -> + let* tree = Tree.remove tree k in + let+ proof = Tree.remove proof k in + Alcotest.(check_repr Store.Hash.t) + (Fmt.str "same hash del %a" Fmt.(Dump.list string) k) + (Tree.hash tree) (Tree.hash proof); + (tree, proof) + | Find k -> + let* v_tree = Tree.find tree k in + let+ v_proof = Tree.find proof k in + Alcotest.(check (option string)) + (Fmt.str "same value at %a" Fmt.(Dump.list string) k) + v_tree v_proof; + (tree, proof) + | Find_tree k -> + let* v_tree = Tree.find_tree tree k in + let+ v_proof = Tree.find_tree tree k in + Alcotest.(check_repr [%typ: Store.tree option]) + (Fmt.str "same tree at %a" Fmt.(Dump.list string) k) + v_tree v_proof; + (tree, proof) + +let test_proofs ctxt ops = + let tree = ctxt.tree in + let key = + match Tree.key tree with Some (`Node h) -> h | _ -> assert false + in + let hash = Tree.hash tree in + + (* Create a compressed parital Merle proof for ops *) + let* proof = proof_of_ops ctxt.repo (`Node key) ops in + + (* test encoding *) + let enc = bin_of_proof proof in + let dec = proof_of_bin enc in + Alcotest.(check_repr tree_proof_t) "same proof" proof dec; + + (* test equivalence *) + let tree_proof = Tree.Proof.to_tree proof in + + Alcotest.(check_repr Store.Hash.t) + "same initial hash" hash (Tree.hash tree_proof); + + let* _ = + Lwt_list.fold_left_s + (fun (tree, proof) op -> check_equivalence tree proof op) + (tree, tree_proof) + [ + Add ([ "00" ], "0"); + Add ([ "00" ], "1"); + Del [ "00" ]; + Find [ "00" ]; + Add ([ "00" ], "0"); + Add ([ "00" ], "1"); + Find [ "00" ]; + Find_tree [ "01" ]; + Find_tree [ "z"; "o"; "o" ]; + ] + in + Lwt.return_unit + +let test_large_inode () = + let bindings = bindings steps in + let* ctxt = init_tree bindings in + let ops = [ Add ([ "00" ], "3"); Del [ "01" ] ] in + test_proofs ctxt ops + +let fewer_steps = +["00"; "01"; "02"; "03"; "05"; "06"; "07"; "09"; "0a"; "0b"; "0c"; +"0e"; "0f"; "10"; "11"; "12"; "13"; "14"; "15"; "16"; "17"; "19"; +"1a"; "1b"; "1c"; "1d"; "1e"; "1f"; "20"; "22"; "23"; "25"; "26"; +"27"; "28"; "2a"; ][@@ocamlformat "disable"] + +let test_small_inode () = + let bindings = bindings fewer_steps in + let* ctxt = init_tree bindings in + let ops = [ Add ([ "00" ], ""); Del [ "01" ] ] in + test_proofs ctxt ops + +let test_deeper_proof () = + let* ctxt = + let tree = Tree.empty () in + let* level_one = + let bindings = bindings fewer_steps in + Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + in + let* level_two = + let* tree = Tree.add_tree tree [ "0g" ] level_one in + let bindings = bindings steps in + Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + in + let* level_three = + let* tree = Tree.add_tree tree [ "1g" ] level_two in + let bindings = bindings fewer_steps in + Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree bindings + in + export_tree_to_store level_three + in + let ops = + [ + Find [ "1g"; "0g"; "00" ]; + Del [ "1g"; "0g"; "01" ]; + Find [ "02" ]; + Find_tree [ "1g"; "02" ]; + ] + in + test_proofs ctxt ops + +module Binary = Make (struct + let entries = 2 + let stable_hash = 2 + let inode_child_order = `Hash_bits + let contents_length_header = Some `Varint + let forbid_empty_dir_persistence = false +end) + +(* test large compressed proofs *) +let test_large_proofs () = + (* Build a proof on a large store (branching factor = 32) *) + let bindings = init_bindings 100_000 in + let ops n = + bindings + |> List.to_seq + |> Seq.take n + |> Seq.map (fun (s, _) -> Find_tree s) + |> List.of_seq + in + + let compare_proofs n = + let ops = ops n in + let* ctxt = init_tree bindings in + let key = + match Tree.key ctxt.tree with Some (`Node k) -> k | _ -> assert false + in + let* proof = proof_of_ops ctxt.repo (`Node key) ops in + let enc_32 = bin_of_proof proof in + let* () = close ctxt in + + (* Build a stream proof *) + let* ctxt = init_tree bindings in + let key = + match Tree.key ctxt.tree with Some (`Node k) -> k | _ -> assert false + in + let* proof = stream_of_ops ctxt.repo (`Node key) ops in + let s_enc_32 = bin_of_stream proof in + let* () = close ctxt in + + (* Build a proof on a large store (branching factor = 2) *) + let* ctxt = Binary.init_tree bindings in + let key = + match Binary.Store.Tree.key ctxt.tree with + | Some (`Node k) -> k + | _ -> assert false + in + let* proof = Binary.proof_of_ops ctxt.repo (`Node key) ops in + let enc_2 = Binary.bin_of_proof proof in + let* () = Binary.close ctxt in + + (* Build a stream proof *) + let* ctxt = Binary.init_tree bindings in + let key = + match Binary.Store.Tree.key ctxt.tree with + | Some (`Node k) -> k + | _ -> assert false + in + let* proof = Binary.stream_of_ops ctxt.repo (`Node key) ops in + let s_enc_2 = Binary.bin_of_stream proof in + let* () = Binary.close ctxt in + + Lwt.return + ( n, + String.length enc_32 / 1024, + String.length s_enc_32 / 1024, + String.length enc_2 / 1024, + String.length s_enc_2 / 1024 ) + in + let* a = compare_proofs 1 in + let* b = compare_proofs 100 in + let* c = compare_proofs 1_000 in + let+ d = compare_proofs 10_000 in + List.iter + (fun (n, k32, sk32, k2, sk2) -> + Fmt.pr "Size of Merkle proof for %d operations:\n" n; + Fmt.pr "- Merkle B-trees (32 children) : %dkB\n%!" k32; + Fmt.pr "- stream Merkle B-trees (32 children): %dkB\n%!" sk32; + Fmt.pr "- binary Merkle trees : %dkB\n%!" k2; + Fmt.pr "- stream binary Merkle trees : %dkB\n%!" sk2) + [ a; b; c; d ] + +module Custom = Make (struct + let entries = 2 + let stable_hash = 2 + + let index ~depth step = + let ascii_code = Bytes.get step depth |> Char.code in + ascii_code - 48 + + let inode_child_order = `Custom index + let contents_length_header = Some `Varint + let forbid_empty_dir_persistence = false +end) + +module P = Custom.Tree.Proof + +let pp_proof = Irmin.Type.pp (P.t P.tree_t) +let pp_stream = Irmin.Type.pp (P.t P.stream_t) + +let check_hash h s = + let s' = Irmin.Type.(to_string Hash.t) h in + Alcotest.(check string) "check hash" s s' + +let check_contents_hash h s = + match h with + | `Node _ -> Alcotest.failf "Expected kinded hash to be contents" + | `Contents (h, ()) -> + let s' = Irmin.Type.(to_string Hash.t) h in + Alcotest.(check string) "check hash" s s' + +let test_extenders () = + let bindings = + [ ([ "00000" ], "x"); ([ "00001" ], "y"); ([ "00010" ], "z") ] + in + let bindings2 = ([ "10000" ], "x1") :: bindings in + let bindings3 = ([ "10001" ], "y") :: bindings2 in + + let f t = + let+ v = Custom.Tree.get t [ "00000" ] in + Alcotest.(check string) "00000" "x" v; + (t, ()) + in + + let check_proof bindings = + let* ctxt = Custom.init_tree bindings in + let key = Custom.Tree.key ctxt.tree |> Option.get in + let* p, () = Custom.Tree.produce_proof ctxt.repo key f in + [%log.debug "Verifying proof %a" pp_proof p]; + let+ r = Custom.Tree.verify_proof p f in + match r with + | Ok (_, ()) -> () + | Error e -> + Alcotest.failf "check_proof: %a" + (Irmin.Type.pp Custom.Tree.verifier_error_t) + e + in + let* () = Lwt_list.iter_s check_proof [ bindings; bindings2; bindings3 ] in + + let check_stream bindings = + let* ctxt = Custom.init_tree bindings in + let key = Custom.Tree.key ctxt.tree |> Option.get in + let* p, () = Custom.Tree.produce_stream ctxt.repo key f in + [%log.debug "Verifying stream %a" pp_stream p]; + let+ r = Custom.Tree.verify_stream p f in + match r with + | Ok (_, ()) -> () + | Error e -> + Alcotest.failf "check_stream: %a" + (Irmin.Type.pp Custom.Tree.verifier_error_t) + e + in + Lwt_list.iter_s check_stream [ bindings; bindings2; bindings3 ] + +let test_hardcoded_stream () = + let bindings = + [ ([ "00100" ], "x"); ([ "00101" ], "y"); ([ "00110" ], "z") ] + in + let fail elt = + Alcotest.failf "Unexpected elt in stream %a" (Irmin.Type.pp P.elt_t) elt + in + let* ctxt = Custom.init_tree bindings in + let key = Custom.Tree.key ctxt.tree |> Option.get in + let f t = + let path = [ "00100" ] in + let+ v = Custom.Tree.get t path in + Alcotest.(check ~pos:__POS__ string) "" (List.assoc path bindings) v; + (t, ()) + in + let* p, () = Custom.Tree.produce_stream ctxt.repo key f in + let state = P.state p in + let counter = ref 0 in + Seq.iter + (fun elt -> + (match !counter with + | 0 -> ( + match elt with + | P.Inode_extender { length; segments = [ 0; 0; 1 ]; proof = h } + when length = 3 -> + check_hash h "25c1a3d3bb7e5124cf61954851d0c9ccf5113d4e" + | _ -> fail elt) + | 1 -> ( + match elt with + | P.Inode { length; proofs = [ (0, h1); (1, h0) ] } when length = 3 -> + check_hash h0 "8410f4d1be1d571f0d63638927d42c7c1c6f3df1"; + check_hash h1 "580c8955c438ca5b1f94d2f4eb712a85e2634b70" + | _ -> fail elt) + | 2 -> ( + match elt with + | P.Node [ ("00100", h0); ("00101", h1) ] -> + check_contents_hash h0 "11f6ad8ec52a2984abaafd7c3b516503785c2072"; + check_contents_hash h1 "95cb0bfd2977c761298d9624e4b4d4c72a39974a" + | _ -> fail elt) + | 3 -> ( match elt with P.Contents "x" -> () | _ -> fail elt) + | _ -> fail elt); + incr counter) + state; + if !counter <> 4 then Alcotest.fail "Not enough elements in the stream"; + Lwt.return_unit + +let test_hardcoded_proof () = + let bindings = + [ ([ "00000" ], "x"); ([ "00001" ], "y"); ([ "00010" ], "z") ] + in + let fail_with_tree elt = + Alcotest.failf "Unexpected elt in proof %a" (Irmin.Type.pp P.tree_t) elt + in + let fail_with_inode_tree elt = + Alcotest.failf "Unexpected elt in proof %a" + (Irmin.Type.pp P.inode_tree_t) + elt + in + let* ctxt = Custom.init_tree bindings in + let key = Custom.Tree.key ctxt.tree |> Option.get in + let f t = + let+ v = Custom.Tree.get t [ "00000" ] in + Alcotest.(check string) "00000" "x" v; + (t, ()) + in + let* p, () = Custom.Tree.produce_proof ctxt.repo key f in + let state = P.state p in + + let check_depth_2 = function + | P.Inode_values + [ ("00000", Contents ("x", ())); ("00001", Blinded_contents (h1, ())) ] + -> + check_hash h1 "95cb0bfd2977c761298d9624e4b4d4c72a39974a" + | t -> fail_with_inode_tree t + in + let check_depth_1 = function + | P.Inode_tree { length = 3; proofs = [ (0, t); (1, P.Blinded_inode h1) ] } + -> + check_hash h1 "4295267989ab4c4a036eb78f0610a57042e2b49f"; + check_depth_2 t + | t -> fail_with_inode_tree t + in + let () = + match (state : P.tree) with + | P.Extender { length = 3; segments = [ 0; 0; 0 ]; proof = t } -> + check_depth_1 t + | _ -> fail_with_tree state + in + Lwt.return_unit + +let tree_of_list ls = + let tree = Tree.empty () in + Lwt_list.fold_left_s (fun tree (k, v) -> Tree.add tree k v) tree ls + +let test_proof_exn _ = + let x = "x" in + let y = "y" in + let hx = Store.Contents.hash x in + let hy = Store.Contents.hash y in + let stream_elt1 : P.elt = Contents y in + let stream_elt2 : P.elt = Contents x in + let stream_elt3 : P.elt = + Node [ ("bx", `Contents (hx, ())); ("by", `Contents (hy, ())) ] + in + let* tree = tree_of_list [ ([ "bx" ], "x"); ([ "by" ], "y") ] in + let hash = Tree.hash tree in + + let stream_all = + P.v ~before:(`Node hash) ~after:(`Node hash) + (List.to_seq [ stream_elt3; stream_elt2; stream_elt1 ]) + in + let stream_short = + P.v ~before:(`Node hash) ~after:(`Node hash) + (List.to_seq [ stream_elt3; stream_elt2 ]) + in + let f_all t = + let* _ = Custom.Tree.find t [ "bx" ] in + let+ _ = Custom.Tree.find t [ "by" ] in + (t, ()) + in + let f_short t = + let+ _ = Custom.Tree.find t [ "bx" ] in + (t, ()) + in + (* Test the Stream_too_long error. *) + let* r = Custom.Tree.verify_stream stream_all f_short in + let* () = + match r with + | Error (`Stream_too_long _) -> Lwt.return_unit + | _ -> Alcotest.fail "expected Stream_too_long error" + in + (* Test the Stream_too_short error. *) + let* r = Custom.Tree.verify_stream stream_short f_all in + let* () = + match r with + | Error (`Stream_too_short _) -> Lwt.return_unit + | _ -> Alcotest.fail "expected Stream_too_short error" + in + (* Test the correct usecase. *) + let* r = Custom.Tree.verify_stream stream_all f_all in + let* () = + match r with + | Ok (_, ()) -> Lwt.return_unit + | Error e -> ( + match e with + | `Proof_mismatch str -> + Alcotest.failf "unexpected Proof_mismatch error: %s" str + | `Stream_too_long str -> + Alcotest.failf "unexpected Stream_too_long error: %s" str + | `Stream_too_short str -> + Alcotest.failf "unexpected Stream_too_short error: %s" str) + in + Lwt.return_unit + +let test_reexport_node () = + let* tree = Store.Tree.add (Store.Tree.empty ()) [ "foo"; "a" ] "a" in + let* repo1 = Store.Repo.v (config ~fresh:true root) in + let* _ = + Store.Backend.Repo.batch repo1 (fun c n _ -> Store.save_tree repo1 c n tree) + in + let* () = Store.Repo.close repo1 in + (* Re-export the same tree using a different repo. *) + let* repo2 = Store.Repo.v (config ~fresh:false root) in + let* _ = + Alcotest.check_raises_lwt "re-export tree from another repo" + (Failure "Can't export the node key from another repo") (fun () -> + Store.Backend.Repo.batch repo2 (fun c n _ -> + Store.save_tree repo2 c n tree)) + in + let* () = Store.Repo.close repo2 in + (* Re-export a fresh tree using a different repo. *) + let* repo2 = Store.Repo.v (config ~fresh:false root) in + let* tree = Store.Tree.add (Store.Tree.empty ()) [ "foo"; "a" ] "a" in + let _ = Store.Tree.hash tree in + let* c1 = Store.Tree.get_tree tree [ "foo" ] in + let* _ = + Store.Backend.Repo.batch repo2 (fun c n _ -> Store.save_tree repo2 c n c1) + in + let* () = + match Store.Tree.destruct c1 with + | `Contents _ -> Alcotest.fail "got `Contents, expected `Node" + | `Node node -> + let* _v = Store.to_backend_node node in + Lwt.return_unit + in + Store.Repo.close repo2 + +let tests = + [ + Alcotest_lwt.test_case "fold over keys in sorted order" `Quick + (fun _switch -> test_fold_sorted); + Alcotest_lwt.test_case "fold over keys in random order" `Quick + (fun _switch -> test_fold_random); + Alcotest_lwt.test_case "fold over keys in undefined order" `Quick + (fun _switch -> test_fold_undefined); + Alcotest_lwt.test_case "test Merkle proof for large inodes" `Quick + (fun _switch -> test_large_inode); + Alcotest_lwt.test_case "test Merkle proof for small inodes" `Quick + (fun _switch -> test_small_inode); + Alcotest_lwt.test_case "test deeper Merkle proof" `Quick (fun _switch -> + test_deeper_proof); + Alcotest_lwt.test_case "test large Merkle proof" `Slow (fun _switch -> + test_large_proofs); + Alcotest_lwt.test_case "test extenders in stream proof" `Quick + (fun _switch -> test_extenders); + Alcotest_lwt.test_case "test hardcoded stream proof" `Quick (fun _switch -> + test_hardcoded_stream); + Alcotest_lwt.test_case "test hardcoded proof" `Quick (fun _switch -> + test_hardcoded_proof); + Alcotest_lwt.test_case "test stream proof exn" `Quick (fun _switch -> + test_proof_exn); + Alcotest_lwt.test_case "test reexport node" `Quick (fun _switch -> + test_reexport_node); + ] diff --git a/vendors/irmin/test/irmin-pack/test_upgrade.ml b/vendors/irmin/test/irmin-pack/test_upgrade.ml new file mode 100644 index 0000000000000000000000000000000000000000..4bd42a3406f1865516c4250da038796bc276ac31 --- /dev/null +++ b/vendors/irmin/test/irmin-pack/test_upgrade.ml @@ -0,0 +1,684 @@ +(* + * Copyright (c) 2022-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Common + +let ( / ) = Filename.concat +let archive_v2_minimal = "test" / "irmin-pack" / "data" / "version_2_minimal" +let archive_v2_always = "test" / "irmin-pack" / "data" / "version_2_always" +let archive_v3_minimal = "test" / "irmin-pack" / "data" / "version_3_minimal" +let archive_v3_always = "test" / "irmin-pack" / "data" / "version_3_always" +let root_local_build = "_build" / "test-upgrade" + +type pack_entry = { + h : Schema.Hash.t; + o : Int63.t; + l : int; + k : [ `b | `n | `c ]; +} +(** [pack_entry]: hash / offset / length / kind *) + +let e h o l k = + let h = + match Irmin.Type.(of_string Schema.Hash.t) h with + | Error (`Msg s) -> Alcotest.failf "failed hash_of_string %s" s + | Ok h -> h + in + let o = Int63.of_int o in + { h; o; l; k } + +(* Objects inserted during preload + + borphan | b01 <- n01 <- n0 <- c0 *) +let borphan = e "c9bfadf2d211aa6da8e2d00732628a0880b7ee98" 0 29 `b +let b01 = e "5368d2c2f4fc5521fe8e8acd17cdd7349aa8f753" 29 25 `b +let n01 = e "9b120e5019dcc6cd90b4d9c9826c9ebbebdc0023" 54 34 `n +let n0 = e "fe0084f902d55464e9e6dbd82fb60fcf058bb6b1" 88 34 `n +let c0 = e "22e159de13b427226e5901defd17f0c14e744205" 122 42 `c + +(* Objects inserted during write1 + + to n01 <- to c0 <- + \ \ + b1 <- n1 <------- c1 | borphan' *) +let b1 = e "7e83ca2a65d6f90a809c8570c6c905a941b87732" 164 24 `b +let n1 = e "2cc1191a4cfbf869c62da4649961455df6e6b424" 188 44 `n +let c1 = e "09468f13334d3120d8798e27a28d23baba628710" 232 51 `c +let borphan' = e "945bcf284cb6f4735eb8eb74553637b43fde996b" 283 30 `b + +(* Objects inserted during write2 + + to c1 <- + \ + b2 <- n2 <- c2 *) +let b2 = e "32f28ea03b1b20126629d2ca63fc6665b0bbb604" 313 24 `b +let n2 = e "bbca871beaebb1b556e498a8e1ccae7817f5f4ff" 337 34 `n +let c2 = e "6d6c9fcf882f1473f5e2bd0cd4b475611c3a5b60" 371 51 `c + +let pack_entries = + [ n0; b1; borphan; c2; c1; b01; borphan'; n1; n2; n01; c0; b2 ] + +let dict_entries = + [ ("step-n01", 1); ("step-b01", 0); ("step-b1", 2); ("step-b2", 3) ] + +let dict_entries = List.to_seq dict_entries |> Hashtbl.of_seq + +let index_entries = + List.map (fun e -> (e.h, e.o)) pack_entries |> List.to_seq |> Hashtbl.of_seq + +let key_of_entry x = + Irmin_pack.Pack_key.v_direct ~hash:x.h ~offset:x.o ~length:x.l + +type start_mode = From_v2 | From_v3 | From_scratch [@@deriving irmin] + +type setup = { + indexing_strategy : [ `always | `minimal ]; + start_mode : start_mode; + lru_size : int; +} +[@@deriving irmin ~pp] + +type phase = + | S1_before_start + | S2_before_write + | S3_before_gc + | S4_before_write + | S5_before_close +[@@deriving irmin ~pp] + +(** A model is updated in conjunction with a store. Both should always reference + the same entries *) +module Model = struct + type t = { + setup : setup; + dict : (string, unit) Hashtbl.t; + suffix : (Int63.t, unit) Hashtbl.t; + index : (Schema.Hash.t, unit) Hashtbl.t; + } + + let v setup = + let dict = Hashtbl.create 5 in + let suffix = Hashtbl.create 5 in + let index = Hashtbl.create 5 in + { setup; dict; suffix; index } + + let preload_dict t = + Hashtbl.replace t.dict "step-b01" (); + Hashtbl.replace t.dict "step-n01" () + + let preload_suffix t = + Hashtbl.replace t.suffix borphan.o (); + Hashtbl.replace t.suffix b01.o (); + Hashtbl.replace t.suffix n01.o (); + Hashtbl.replace t.suffix n0.o (); + Hashtbl.replace t.suffix c0.o () + + let preload_index t = + if t.setup.indexing_strategy = `always then ( + Hashtbl.replace t.index borphan.h (); + Hashtbl.replace t.index b01.h (); + Hashtbl.replace t.index n01.h (); + Hashtbl.replace t.index n0.h ()); + Hashtbl.replace t.index c0.h () + + let preload t = + preload_suffix t; + preload_index t; + preload_dict t + + let write1_dict t = Hashtbl.replace t.dict "step-b1" () + + let write1_suffix t = + Hashtbl.replace t.suffix b1.o (); + Hashtbl.replace t.suffix n1.o (); + Hashtbl.replace t.suffix c1.o (); + Hashtbl.replace t.suffix borphan'.o () + + let write1_index t = + if t.setup.indexing_strategy = `always then ( + Hashtbl.replace t.index b1.h (); + Hashtbl.replace t.index n1.h (); + Hashtbl.replace t.index borphan'.h ()); + Hashtbl.replace t.index c1.h () + + let write1 t = + write1_suffix t; + write1_index t; + write1_dict t + + let gc t = + Hashtbl.remove t.suffix borphan.o; + Hashtbl.remove t.suffix n0.o; + Hashtbl.remove t.suffix c0.o + + let write2_dict t = Hashtbl.replace t.dict "step-b2" () + + let write2_suffix t = + Hashtbl.replace t.suffix b2.o (); + Hashtbl.replace t.suffix n2.o (); + Hashtbl.replace t.suffix c2.o () + + let write2_index t = + if t.setup.indexing_strategy = `always then ( + Hashtbl.replace t.index b2.h (); + Hashtbl.replace t.index n2.h ()); + Hashtbl.replace t.index c2.h () + + let write2 t = + write2_suffix t; + write2_index t; + write2_dict t + + (** The 5 different states in which a model may be *) + include struct + let create_empty setup = v setup + + let create_after_preload setup = + let m = v setup in + preload m; + m + + let create_after_write1 setup = + let m = v setup in + preload m; + write1 m; + m + + let create_after_gc setup = + let m = v setup in + preload m; + write1 m; + gc m; + m + + let create_after_write2 setup = + let m = v setup in + preload m; + write1 m; + gc m; + write2 m; + m + end +end + +(** A store is updated in conjunction with a model. Both should always reference + the same entries *) +module Store = struct + module S = struct + module Maker = Irmin_pack_unix.Maker (Conf) + include Maker.Make (Schema) + end + + type repo = S.repo + + let config setup ?(readonly = false) ?(fresh = true) root = + let module Index = Irmin_pack.Indexing_strategy in + let indexing_strategy = + if setup.indexing_strategy = `always then Index.always else Index.minimal + in + let lru_size = setup.lru_size in + Irmin_pack.config ~readonly ~indexing_strategy ~lru_size ~fresh root + + let v setup ~readonly ~fresh root = + S.Repo.v (config setup ~readonly ~fresh root) + + let close = S.Repo.close + let reload = S.reload + + let gc repo = + let k = key_of_entry c1 in + let* launched = S.start_gc ~unlink:true ~throttle:`Block repo k in + assert launched; + let* wait = S.finalise_gc ~wait:true repo in + assert wait; + Lwt.return_unit + + let dict_find_opt (repo : S.repo) step = S.Dict.find repo.dict step + + let index_find_opt (repo : S.repo) hash = + S.Index.find (S.File_manager.index repo.fm) hash + + let suffix_mem (repo : S.repo) e = + let k = key_of_entry e in + try + match e.k with + | `c -> S.Backend.Commit.mem (S.Backend.Repo.commit_t repo) k + | `n -> S.Backend.Node.mem (S.Backend.Repo.node_t repo) k + | `b -> S.Backend.Contents.mem (S.Backend.Repo.contents_t repo) k + with Irmin_pack_unix.Pack_store.Invalid_read _ -> + (* In RW mode, [mem] will raise an exception if the offset of the key is + out of the bounds of the pack file *) + Lwt.return_false + + let put_borphan bstore = + let+ k = S.Backend.Contents.add bstore "borphan" in + assert (k = key_of_entry borphan); + k + + let put_b01 bstore = + let+ k = S.Backend.Contents.add bstore "b01" in + assert (k = key_of_entry b01); + k + + let put_n01 bstore nstore = + let* k_b01 = put_b01 bstore in + let step = "step-b01" in + let childs = [ (step, `Contents (k_b01, ())) ] in + let n = S.Backend.Node.Val.of_list childs in + let+ k = S.Backend.Node.add nstore n in + assert (k = key_of_entry n01); + k + + let put_n0 bstore nstore = + let* k_n01 = put_n01 bstore nstore in + let step = "step-n01" in + let childs = [ (step, `Node k_n01) ] in + let n = S.Backend.Node.Val.of_list childs in + let+ k = S.Backend.Node.add nstore n in + assert (k = key_of_entry n0); + k + + let put_c0 bstore nstore cstore = + let* k_n0 = put_n0 bstore nstore in + let c = S.Backend.Commit.Val.v ~info:S.Info.empty ~node:k_n0 ~parents:[] in + let+ k = S.Backend.Commit.add cstore c in + assert (k = key_of_entry c0); + k + + let put_b1 bstore = + let+ k = S.Backend.Contents.add bstore "b1" in + k + + let put_n1 bstore nstore = + let* k_b1 = put_b1 bstore in + let k_n01 = key_of_entry n01 in + let step = "step-b1" in + let step' = "step-b01" in + let childs = [ (step, `Contents (k_b1, ())); (step', `Node k_n01) ] in + let n = S.Backend.Node.Val.of_list childs in + let+ k = S.Backend.Node.add nstore n in + assert (k = key_of_entry n1); + k + + let put_c1 bstore nstore cstore = + let* k_n1 = put_n1 bstore nstore in + let k_c0 = key_of_entry c0 in + let c = + S.Backend.Commit.Val.v ~info:S.Info.empty ~node:k_n1 ~parents:[ k_c0 ] + in + let+ k = S.Backend.Commit.add cstore c in + assert (k = key_of_entry c1); + k + + let put_borphan' bstore = + let+ k = S.Backend.Contents.add bstore "borphan'" in + assert (k = key_of_entry borphan'); + k + + let put_b2 bstore = + let+ k = S.Backend.Contents.add bstore "b2" in + assert (k = key_of_entry b2); + k + + let put_n2 bstore nstore = + let* k_b2 = put_b2 bstore in + let step = "step-b2" in + let childs = [ (step, `Contents (k_b2, ())) ] in + let n = S.Backend.Node.Val.of_list childs in + let+ k = S.Backend.Node.add nstore n in + assert (k = key_of_entry n2); + k + + let put_c2 bstore nstore cstore = + let* k_n2 = put_n2 bstore nstore in + let k_c1 = key_of_entry c1 in + let c = + S.Backend.Commit.Val.v ~info:S.Info.empty ~node:k_n2 ~parents:[ k_c1 ] + in + let+ k = S.Backend.Commit.add cstore c in + assert (k = key_of_entry c2); + k + + let preload repo = + S.Backend.Repo.batch repo (fun bstore nstore cstore -> + let* _ = put_borphan bstore in + let* _ = put_c0 bstore nstore cstore in + Lwt.return_unit) + + let write1 repo = + S.Backend.Repo.batch repo (fun bstore nstore cstore -> + let* _ = put_c1 bstore nstore cstore in + let* _ = put_borphan' bstore in + Lwt.return_unit) + + let write2 repo = + S.Backend.Repo.batch repo (fun bstore nstore cstore -> + let* _ = put_c2 bstore nstore cstore in + Lwt.return_unit) +end + +exception Skip_the_rest_of_that_test + +type hash = Store.S.hash [@@deriving irmin ~pp] + +type t = { + setup : setup; + mutable ro : (Model.t * Store.repo) option; + mutable rw : (Model.t * Store.repo) option; +} + +let check_dict repo model = + Hashtbl.iter + (fun step idx -> + let got = Store.dict_find_opt repo idx in + let exp = Hashtbl.mem model.Model.dict step in + match (got, exp) with + | None, false -> () + | Some step', true -> + let msg = Fmt.str "Dict entry with id:%d" idx in + Alcotest.(check string) msg step step' + | Some step', false -> + Alcotest.failf + "Dict entry with id:%d step:%s shouldn't be there (it's under step \ + %s)" + idx step step' + | None, true -> + Alcotest.failf "Dict entry with id:%d step:%s missing" idx step) + dict_entries + +let check_index repo model = + Hashtbl.iter + (fun hash off -> + let got = Store.index_find_opt repo hash in + let exp = Hashtbl.mem model.Model.index hash in + match (got, exp) with + | None, false -> () + | Some (off', _, _), true -> + let msg = Fmt.str "Index entry with hash:%a" pp_hash hash in + Alcotest.(check int) msg (Int63.to_int off) (Int63.to_int off') + | Some (off', _, _), false -> + Alcotest.failf + "Index entry with hash:%a offset:%d shouldn't be there (it \ + contains offset %d)" + pp_hash hash (Int63.to_int off) (Int63.to_int off') + | None, true -> + Alcotest.failf "Index entry with hash:%a off:%d is missing" pp_hash + hash (Int63.to_int off)) + index_entries + +let check_suffix repo model = + Lwt_list.iter_s + (fun e -> + let+ got = Store.suffix_mem repo e in + let exp = Hashtbl.mem model.Model.suffix e.o in + match (got, exp) with + | false, false -> () + | true, true -> () + | true, false -> + Alcotest.failf "Pack entry with hash:%a off:%d shouldn't be there" + pp_hash e.h (Int63.to_int e.o) + | false, true -> + Alcotest.failf "Pack entry with hash:%a off:%d is missing" pp_hash e.h + (Int63.to_int e.o)) + pack_entries + +let check t = + Lwt_list.iter_s + (fun (model, repo) -> + check_dict repo model; + check_index repo model; + check_suffix repo model) + (Option.to_list t.ro @ Option.to_list t.rw) + +let create_test_env setup = + rm_dir root_local_build; + let () = + match setup.start_mode with + | From_scratch -> () + | From_v2 -> + let root_archive = + if setup.indexing_strategy = `always then archive_v2_always + else archive_v2_minimal + in + setup_test_env ~root_archive ~root_local_build + | From_v3 -> + let root_archive = + if setup.indexing_strategy = `always then archive_v3_always + else archive_v3_minimal + in + setup_test_env ~root_archive ~root_local_build + in + { setup; rw = None; ro = None } + +(** One of the 4 rw mutations *) +let start_rw t = + [%logs.app "*** start_rw %a" pp_setup t.setup]; + let+ rw = + match t.rw with + | Some _ -> assert false + | None -> + let model = + match t.setup.start_mode with + | From_v2 | From_v3 -> + (* Model with pre-loaded data. *) + let m = Model.v t.setup in + Model.preload m; + m + | From_scratch -> Model.v t.setup + in + let+ repo = + Store.v t.setup ~readonly:false ~fresh:false root_local_build + in + (model, repo) + in + t.rw <- Some rw + +(** One of the 4 rw mutations *) +let write1_rw t = + [%logs.app "*** write1_rw %a" pp_setup t.setup]; + match t.rw with + | None -> assert false + | Some (_, repo) -> + t.rw <- Some (Model.create_after_write1 t.setup, repo); + let* () = + (* If the preload commit is not yet in the store, add it. Note that + adding the same commit twice is not idempotent in indexing strategy + minimal, therefore we need to make this distinction. *) + if t.setup.start_mode = From_scratch then + let* _ = Store.preload repo in + Lwt.return_unit + else Lwt.return_unit + in + let* _ = Store.write1 repo in + Lwt.return_unit + +(** One of the 4 rw mutations *) +let gc_rw t = + [%logs.app "*** gc_rw %a" pp_setup t.setup]; + match t.rw with + | None -> assert false + | Some (_, repo) -> + t.rw <- Some (Model.create_after_gc t.setup, repo); + let* () = + match (t.setup.start_mode, t.setup.indexing_strategy) with + | From_v2, _ | _, `always -> + let* () = + Alcotest.check_raises_lwt "GC on V2/always" + (Irmin_pack_unix.Errors.Pack_error `Gc_disallowed) (fun () -> + Store.gc repo) + in + raise Skip_the_rest_of_that_test + | (From_v3 | From_scratch), `minimal -> Store.gc repo + in + Lwt.return_unit + +(** One of the 4 rw mutations *) +let write2_rw t = + [%logs.app "*** write2_rw %a" pp_setup t.setup]; + match t.rw with + | None -> assert false + | Some (_, repo) -> + t.rw <- Some (Model.create_after_write2 t.setup, repo); + let* _ = Store.write2 repo in + Lwt.return_unit + +(** One of the 2 ro mutations *) +let open_ro t current_phase = + [%logs.app "*** open_ro %a, %a" pp_setup t.setup pp_phase current_phase]; + let+ ro = + match t.ro with + | Some _ -> assert false + | None -> + let model = + match (t.setup.start_mode, current_phase) with + | From_scratch, (S1_before_start | S2_before_write) -> + Model.create_empty t.setup + | (From_v2 | From_v3), (S1_before_start | S2_before_write) -> + Model.create_after_preload t.setup + | (From_v2 | From_v3 | From_scratch), S3_before_gc -> + Model.create_after_write1 t.setup + | (From_v2 | From_v3 | From_scratch), S4_before_write -> + Model.create_after_gc t.setup + | (From_v2 | From_v3 | From_scratch), S5_before_close -> + Model.create_after_write2 t.setup + in + let fail_and_skip error = + let* () = + Alcotest.check_raises_lwt "open empty/V2 store in RO" + (Irmin_pack_unix.Errors.Pack_error error) (fun () -> + let* repo = + Store.v t.setup ~readonly:true ~fresh:false root_local_build + in + Store.close repo) + in + raise Skip_the_rest_of_that_test + in + let+ repo = + match (t.setup.start_mode, current_phase) with + | From_scratch, S1_before_start -> + fail_and_skip `No_such_file_or_directory + | From_v2, S1_before_start -> fail_and_skip `Migration_needed + | (From_v2 | From_v3 | From_scratch), _ -> + Store.v t.setup ~readonly:true ~fresh:false root_local_build + in + (model, repo) + in + t.ro <- Some ro + +(** One of the 2 ro mutations *) +let sync_ro t current_phase = + [%logs.app "*** sync_ro %a, %a" pp_setup t.setup pp_phase current_phase]; + match t.ro with + | None -> assert false + | Some (_, repo) -> + let () = + match current_phase with + | S1_before_start | S2_before_write -> () + | S3_before_gc -> t.ro <- Some (Model.create_after_write1 t.setup, repo) + | S4_before_write -> t.ro <- Some (Model.create_after_gc t.setup, repo) + | S5_before_close -> + t.ro <- Some (Model.create_after_write2 t.setup, repo) + in + Store.reload repo + +let close_everything t = + Lwt_list.iter_s + (fun (_, repo) -> Store.close repo) + (Option.to_list t.ro @ Option.to_list t.rw) + +let test_one t ~ro_open_at ~ro_sync_at = + let aux phase = + let* () = check t in + let* () = if ro_open_at = phase then open_ro t phase else Lwt.return_unit in + let* () = check t in + if ro_sync_at = phase then sync_ro t phase; + let* () = check t in + Lwt.return_unit + in + + let* () = aux S1_before_start in + let* () = start_rw t in + let* () = aux S2_before_write in + let* () = write1_rw t in + let* () = aux S3_before_gc in + let* () = gc_rw t in + let* () = aux S4_before_write in + let* () = write2_rw t in + let* () = aux S5_before_close in + Lwt.return_unit + +let test_one_guarded setup ~ro_open_at ~ro_sync_at = + let t = create_test_env setup in + Lwt.catch + (fun () -> + let* () = test_one t ~ro_open_at ~ro_sync_at in + close_everything t) + (function + | Skip_the_rest_of_that_test -> + [%logs.app "*** skip rest of %a" pp_setup setup]; + close_everything t + | exn -> Lwt.fail exn) + +(** All possible interleaving of the ro calls (open and sync) with the rw calls + (open, write1, gc and write2). *) +let test start_mode indexing_strategy lru_size = + let setup = { start_mode; indexing_strategy; lru_size } in + let t = test_one_guarded setup in + + let* () = t ~ro_open_at:S1_before_start ~ro_sync_at:S1_before_start in + let* () = t ~ro_open_at:S1_before_start ~ro_sync_at:S2_before_write in + let* () = t ~ro_open_at:S1_before_start ~ro_sync_at:S3_before_gc in + let* () = t ~ro_open_at:S1_before_start ~ro_sync_at:S4_before_write in + let* () = t ~ro_open_at:S1_before_start ~ro_sync_at:S5_before_close in + + let* () = t ~ro_open_at:S2_before_write ~ro_sync_at:S2_before_write in + let* () = t ~ro_open_at:S2_before_write ~ro_sync_at:S3_before_gc in + let* () = t ~ro_open_at:S2_before_write ~ro_sync_at:S4_before_write in + let* () = t ~ro_open_at:S2_before_write ~ro_sync_at:S5_before_close in + + let* () = t ~ro_open_at:S3_before_gc ~ro_sync_at:S3_before_gc in + let* () = t ~ro_open_at:S3_before_gc ~ro_sync_at:S4_before_write in + let* () = t ~ro_open_at:S3_before_gc ~ro_sync_at:S5_before_close in + + let* () = t ~ro_open_at:S4_before_write ~ro_sync_at:S4_before_write in + let* () = t ~ro_open_at:S4_before_write ~ro_sync_at:S5_before_close in + + let* () = t ~ro_open_at:S5_before_close ~ro_sync_at:S5_before_close in + Lwt.return_unit + +(** Product on lru_size *) +let test start_mode indexing_strategy = + let* () = test start_mode indexing_strategy 0 in + let* () = test start_mode indexing_strategy 100 in + Lwt.return_unit + +(** Product on indexing_strategy *) +let test start_mode () = + let* () = test start_mode `minimal in + let* () = test start_mode `always in + Lwt.return_unit + +(** Product on start_mode *) +let tests = + [ + Alcotest_lwt.test_case "upgrade From_v3" `Quick (fun _switch () -> + test From_v3 ()); + Alcotest_lwt.test_case "upgrade From_v2" `Quick (fun _switch () -> + test From_v2 ()); + Alcotest_lwt.test_case "upgrade From_scratch" `Quick (fun _switch () -> + test From_scratch ()); + ] diff --git a/vendors/irmin/test/irmin-tezos/dune b/vendors/irmin/test/irmin-tezos/dune new file mode 100644 index 0000000000000000000000000000000000000000..43186b51d431b5f225c23e3b5744b29596b785c1 --- /dev/null +++ b/vendors/irmin/test/irmin-tezos/dune @@ -0,0 +1,33 @@ +(executable + (name irmin_fsck) + (modules irmin_fsck) + (libraries irmin-pack irmin-pack.unix irmin-tezos)) + +(executable + (name generate) + (modules generate) + (libraries irmin-tezos irmin-pack irmin-pack.unix)) + +(rule + (alias generate-cli-test-data) + (targets data) + (action + (run %{exe:generate.exe}))) + +(cram + (package irmin-tezos) + (deps + (file irmin_fsck.exe) + (file data) + (alias generate-cli-test-data))) + +;FIXME: we should not depend on the version of cmdliner +;(rule +; (alias runtest) +; (package irmin-tezos) +; (action +; (progn +; (with-stdout-to +; irmin-fsck-help.txt.gen +; (run %{exe:irmin_fsck.exe} --help=plain)) +; (diff? irmin-fsck-help.txt irmin-fsck-help.txt.gen)))) diff --git a/vendors/irmin/test/irmin-tezos/generate.ml b/vendors/irmin/test/irmin-tezos/generate.ml new file mode 100644 index 0000000000000000000000000000000000000000..c47da5fad84117642148b0767d5a2a302020a9f6 --- /dev/null +++ b/vendors/irmin/test/irmin-tezos/generate.ml @@ -0,0 +1,68 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Lwt.Syntax + +let rm_dir data_dir = + if Sys.file_exists data_dir then ( + let cmd = Printf.sprintf "rm -rf %s" data_dir in + Fmt.epr "exec: %s\n%!" cmd; + let _ = Sys.command cmd in + ()) + +module Simple = struct + let data_dir = "data/pack" + + module Conf = struct + include Irmin_tezos.Conf + + let entries = 2 + let stable_hash = 3 + end + + module Schema = Irmin.Schema.KV (Irmin.Contents.String) + + module Store = struct + open Irmin_pack_unix.Maker (Conf) + include Make (Schema) + end + + let config root = Irmin_pack.config ~readonly:false ~fresh:true root + let info = Store.Info.empty + + let create_store () = + rm_dir data_dir; + (* make sure the parent directory data/ exists; by default Store.Repo.v will not + create the containing directory *) + if not (Sys.file_exists "data") then Unix.mkdir "data" 0o755; + let* rw = Store.Repo.v (config data_dir) in + let tree = Store.Tree.singleton [ "a"; "b1"; "c1"; "d1"; "e1" ] "x1" in + let* tree = Store.Tree.add tree [ "a"; "b1"; "c1"; "d2"; "e2" ] "x2" in + let* tree = Store.Tree.add tree [ "a"; "b1"; "c1"; "d3"; "e3" ] "x2" in + let* tree = Store.Tree.add tree [ "a"; "b2"; "c2"; "e3" ] "x2" in + let* c1 = Store.Commit.v rw ~parents:[] ~info tree in + + let* tree = Store.Tree.add tree [ "a"; "b3" ] "x3" in + let* c2 = Store.Commit.v rw ~parents:[ Store.Commit.key c1 ] ~info tree in + + let* tree = Store.Tree.remove tree [ "a"; "b1"; "c1" ] in + let* _ = Store.Commit.v rw ~parents:[ Store.Commit.key c2 ] ~info tree in + + Store.Repo.close rw +end + +let generate () = Simple.create_store () +let () = Lwt_main.run (generate ()) diff --git a/vendors/irmin/test/irmin-tezos/generate.mli b/vendors/irmin/test/irmin-tezos/generate.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/test/irmin-tezos/generate.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin-tezos/irmin-fsck-help.txt b/vendors/irmin/test/irmin-tezos/irmin-fsck-help.txt new file mode 100644 index 0000000000000000000000000000000000000000..6709f144378769d5f2a363661a9112ddf0b70da3 --- /dev/null +++ b/vendors/irmin/test/irmin-tezos/irmin-fsck-help.txt @@ -0,0 +1,33 @@ +NAME + irmin-fsck - Check Irmin data-stores. + +SYNOPSIS + irmin-fsck COMMAND ... + +COMMANDS + integrity-check + Check integrity of an existing store. + + integrity-check-index + Check index integrity. + + integrity-check-inodes + Check integrity of inodes in an existing store. + + reconstruct-index + Reconstruct index from an existing pack file. + + stat + Print high-level statistics about the store. + + stat-store + Traverse one commit, specified with the --commit argument, in the + store for stats. If no commit is specified the current head is + used. + +OPTIONS + --help[=FMT] (default=auto) + Show this help in format FMT. The value FMT must be one of `auto', + `pager', `groff' or `plain'. With `auto', the format is `pager` or + `plain' whenever the TERM env var is `dumb' or undefined. + diff --git a/vendors/irmin/test/irmin-tezos/irmin_fsck.ml b/vendors/irmin/test/irmin-tezos/irmin_fsck.ml new file mode 100644 index 0000000000000000000000000000000000000000..ac0be3236458ab542aea2300d7aa200d555b1d4a --- /dev/null +++ b/vendors/irmin/test/irmin-tezos/irmin_fsck.ml @@ -0,0 +1,38 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Schema = Irmin.Schema.KV (Irmin.Contents.String) + +module Maker = struct + module Maker = Irmin_pack_unix.Maker (Irmin_tezos.Conf) + include Maker.Make (Schema) +end + +module Store = Irmin_pack_unix.Checks.Make (Maker) + +module Maker_tz = struct + module Maker = Irmin_pack_unix.Maker (Irmin_tezos.Conf) + include Maker.Make (Irmin_tezos.Schema) +end + +module Store_tz = Irmin_pack_unix.Checks.Make (Maker_tz) + +let () = + try + let store_type = Sys.getenv "STORE" in + if store_type = "PACK" then match Store.cli () with _ -> . + else raise Not_found + with Not_found -> ( match Store_tz.cli () with _ -> .) diff --git a/vendors/irmin/test/irmin/data/dune b/vendors/irmin/test/irmin/data/dune new file mode 100644 index 0000000000000000000000000000000000000000..415dd47b0005fd7210937642cf338f790412b926 --- /dev/null +++ b/vendors/irmin/test/irmin/data/dune @@ -0,0 +1,4 @@ +(test + (name test) + (package irmin) + (libraries irmin.data alcotest vector fmt)) diff --git a/vendors/irmin/test/irmin/data/import.ml b/vendors/irmin/test/irmin/data/import.ml new file mode 100644 index 0000000000000000000000000000000000000000..38df5ec8bab9946e9f4b262fc00aab0c26057da7 --- /dev/null +++ b/vendors/irmin/test/irmin/data/import.ml @@ -0,0 +1,22 @@ +let check typ pos ~expected actual = + Alcotest.(check ~pos typ) "" expected actual + +let check_bool = check Alcotest.bool + +let check_ok_or_duplicate = + let pp : [ `Ok | `Duplicate ] Fmt.t = + Fmt.of_to_string (function `Ok -> "`Ok" | `Duplicate -> "`Duplicate") + in + check (Alcotest.testable pp ( = )) + +let check_invalid_arg pos f = + let fail got = + Alcotest.failf ~pos + "Expected function to raise `Invalid_argument`, but raised: %a" + Fmt.(Dump.option exn) + got + in + match f () with + | _ -> fail None + | exception Invalid_argument _ -> () + | exception exn -> fail (Some exn) diff --git a/vendors/irmin/test/irmin/data/test.ml b/vendors/irmin/test/irmin/data/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..291685956585f7a886d40215bc0daf4f7ee985e2 --- /dev/null +++ b/vendors/irmin/test/irmin/data/test.ml @@ -0,0 +1,6 @@ +open! Import + +let () = + Random.self_init (); + Alcotest.run __FILE__ + [ ("Fixed_size_string_set", Test_fixed_size_string_set.tests) ] diff --git a/vendors/irmin/test/irmin/data/test.mli b/vendors/irmin/test/irmin/data/test.mli new file mode 100644 index 0000000000000000000000000000000000000000..468d18d917adf109591ac82c4f3e82f5039a2177 --- /dev/null +++ b/vendors/irmin/test/irmin/data/test.mli @@ -0,0 +1 @@ +(* Intentionally empty *) diff --git a/vendors/irmin/test/irmin/data/test_fixed_size_string_set.ml b/vendors/irmin/test/irmin/data/test_fixed_size_string_set.ml new file mode 100644 index 0000000000000000000000000000000000000000..42d50d00ae0713326fd18cfb69eb4b4a01a5a3ef --- /dev/null +++ b/vendors/irmin/test/irmin/data/test_fixed_size_string_set.ml @@ -0,0 +1,104 @@ +open! Import +module String_set = Irmin_data.Fixed_size_string_set + +let hash : string -> int = Hashtbl.hash + +let hash_substring : Bigstringaf.t -> off:int -> len:int -> int = + fun t ~off ~len -> hash (Bigstringaf.substring t ~off ~len) + +let test_add_and_mem () = + let set = + String_set.create ~elt_length:1 ~initial_slots:0 ~hash ~hash_substring () + in + String_set.mem set "a" |> check_bool __POS__ ~expected:false; + String_set.add_exn set "a"; + String_set.mem set "a" |> check_bool __POS__ ~expected:true; + String_set.add_exn set "b"; + String_set.add_exn set "c"; + + String_set.mem set "a" |> check_bool __POS__ ~expected:true; + String_set.mem set "b" |> check_bool __POS__ ~expected:true; + String_set.mem set "c" |> check_bool __POS__ ~expected:true; + + String_set.add set "a" |> check_ok_or_duplicate __POS__ ~expected:`Duplicate; + String_set.add set "b" |> check_ok_or_duplicate __POS__ ~expected:`Duplicate; + String_set.add set "c" |> check_ok_or_duplicate __POS__ ~expected:`Duplicate; + String_set.add set "d" |> check_ok_or_duplicate __POS__ ~expected:`Ok + +let test_random () = + let elt_length = 8 in + let set = + String_set.create ~elt_length ~initial_slots:31 ~hash ~hash_substring () + in + let reference_tbl = Stdlib.Hashtbl.create 0 in + let reference_vector = Vector.create ~dummy:"" in + let random_string () = + String.init elt_length (fun _ -> char_of_int (Random.int 256)) + in + for i = 0 to 10_000 do + (* Add a new element: *) + let new_elt = random_string () in + String_set.add_exn set new_elt; + Stdlib.Hashtbl.add reference_tbl new_elt (); + Vector.push reference_vector new_elt; + + (* Pick a random existing element and check [mem] is true: *) + let elt = Vector.get reference_vector (Random.int (i + 1)) in + assert (Stdlib.Hashtbl.mem reference_tbl elt); + String_set.mem set elt |> check_bool __POS__ ~expected:true; + + (* Pick a random non-existing element and check [mem] is false: *) + let non_elt = random_string () in + assert (not (Stdlib.Hashtbl.mem reference_tbl non_elt)); + String_set.mem set non_elt |> check_bool __POS__ ~expected:false; + + (* Check that the internal invariants hold, and that all internal elements + are also contained in the reference: *) + if i mod 1_000 = 0 then + String_set.invariant + (fun elt -> + check_bool __POS__ ~expected:true + (Stdlib.Hashtbl.mem reference_tbl elt)) + set + done + +let test_invalid_argument () = + (* [create] *) + let () = + (* Must have a positive [elt_length]: *) + check_invalid_arg __POS__ (fun () -> String_set.create ~elt_length:0 ()); + + (* Cannot pass [hash] without passing [hash_substring] (and vice versa): *) + check_invalid_arg __POS__ (fun () -> + String_set.create ~elt_length:1 ~hash:(fun _ -> assert false) ()); + check_invalid_arg __POS__ (fun () -> + String_set.create ~elt_length:1 + ~hash_substring:(fun _ -> assert false) + ()) + in + + (* [add] *) + let () = + let null = "0" in + let t = String_set.create ~elt_length:1 ~null () in + + (* Element must have the correct length: *) + check_invalid_arg __POS__ (fun () -> String_set.add_exn t ""); + + (* Cannot add the null element: *) + check_invalid_arg __POS__ (fun () -> String_set.add_exn t null); + + (* An exception is raised on adding a duplicate element: *) + String_set.add_exn t "a"; + check_invalid_arg __POS__ (fun () -> String_set.add_exn t "a") + in + + () + +let tests = + let test name fn = Alcotest.test_case name `Quick fn in + [ + test "add_and_mem" test_add_and_mem; + test "random" test_random; + test "invalid_argument" test_invalid_argument; + ] diff --git a/vendors/irmin/test/irmin/data/test_fixed_size_string_set.mli b/vendors/irmin/test/irmin/data/test_fixed_size_string_set.mli new file mode 100644 index 0000000000000000000000000000000000000000..d38ba9a90a2bad218b5cc46f405e9b34a6e2822c --- /dev/null +++ b/vendors/irmin/test/irmin/data/test_fixed_size_string_set.mli @@ -0,0 +1 @@ +val tests : unit Alcotest.test_case list diff --git a/vendors/irmin/test/irmin/dune b/vendors/irmin/test/irmin/dune new file mode 100644 index 0000000000000000000000000000000000000000..219309ffdf320af54a47915ef36d57c7887bcab7 --- /dev/null +++ b/vendors/irmin/test/irmin/dune @@ -0,0 +1,17 @@ +(test + (name test) + ;; Attached to `irmin-test` to avoid a cyclic dependency with `irmin` + (package irmin-test) + (preprocess + (pps ppx_irmin.internal)) + (libraries + irmin + irmin.mem + irmin-test + alcotest + alcotest-lwt + lwt + lwt.unix + hex + logs + logs.fmt)) diff --git a/vendors/irmin/test/irmin/generic-key/dune b/vendors/irmin/test/irmin/generic-key/dune new file mode 100644 index 0000000000000000000000000000000000000000..96e1b41b091993763138abc8f9c4f0963472209c --- /dev/null +++ b/vendors/irmin/test/irmin/generic-key/dune @@ -0,0 +1,15 @@ +(test + (name test) + ;; Attached to `irmin-test` to avoid a cyclic dependency with `irmin` + (package irmin-test) + (preprocess + (pps ppx_irmin.internal)) + (libraries + irmin + irmin.mem + irmin-test + alcotest + alcotest-lwt + lwt + lwt.unix + vector)) diff --git a/vendors/irmin/test/irmin/generic-key/test.ml b/vendors/irmin/test/irmin/generic-key/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..28f52b7cea792474e051f53346f92afb8573c4ea --- /dev/null +++ b/vendors/irmin/test/irmin/generic-key/test.ml @@ -0,0 +1,22 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let () = + Lwt_main.run + @@ Irmin_test.Store.run __FILE__ ~slow:true ~misc:[] ~sleep:Lwt_unix.sleep + [ + (`Quick, Test_store_offset.suite); (`Quick, Test_inlined_contents.suite); + ] diff --git a/vendors/irmin/test/irmin/generic-key/test_inlined_contents.ml b/vendors/irmin/test/irmin/generic-key/test_inlined_contents.ml new file mode 100644 index 0000000000000000000000000000000000000000..755689678dce3ac4c98cf0465705f5206bc592c5 --- /dev/null +++ b/vendors/irmin/test/irmin/generic-key/test_inlined_contents.ml @@ -0,0 +1,94 @@ +open Irmin + +(** A store in which all values are stored as immediates inside their respective + keys. The store itself keeps no information, except for the bookkeeping + needed to handle [clear]-ing the in-memory keys. *) +module Keyed_by_value = struct + type (_, 'v) key = { value : 'v } + + module Key (Hash : Hash.S) (Value : Type.S) = struct + type t = (Hash.t, Value.t) key + type hash = Hash.t [@@deriving irmin ~pre_hash] + type value = Value.t [@@deriving irmin ~pre_hash] + + let value_to_hash t = Hash.hash (fun f -> pre_hash_value t f) + let to_hash t = value_to_hash t.value + + let (t : t Type.t) = + let open Type in + map + ~pre_hash:(fun t f -> + let hash = value_to_hash t.value in + pre_hash_hash hash f) + Value.t + (fun _ -> + Alcotest.fail ~pos:__POS__ "Key implementation is non-serialisable") + (fun t -> t.value) + end + + module Make (Hash : Hash.S) (Value : Type.S) = struct + type _ t = { instance : unit option ref } + type hash = Hash.t + type value = Value.t + + module Key = Key (Hash) (Value) + + type key = Key.t + + let check_not_closed t = + match !(t.instance) with None -> raise Closed | Some t -> t + + let v _ = Lwt.return { instance = ref (Some ()) } + + let mem t _ = + let _ = check_not_closed t in + Lwt.return_true + + let unsafe_add t _ value = + let _ = check_not_closed t in + Lwt.return { value } + + let add t v = unsafe_add t () v + + let find t k = + let _ = check_not_closed t in + Lwt.return_some k.value + + let index _ _ = Lwt.return_none + let batch t f = f (t :> Perms.read_write t) + + let close t = + t.instance := None; + Lwt.return_unit + end +end + +module Plain = struct + type 'h key = 'h + + module Key = Key.Of_hash + + module Make (H : Hash.S) (V : Type.S) = struct + module CA = + Content_addressable.Check_closed (Irmin_mem.Content_addressable) (H) (V) + + include Indexable.Of_content_addressable (H) (CA) + + let v = CA.v + end +end + +module Store_maker = Generic_key.Maker (struct + module Contents_store = Keyed_by_value + module Node_store = Plain + module Commit_store = Plain + module Branch_store = Atomic_write.Check_closed (Irmin_mem.Atomic_write) +end) + +module Store = Store_maker.Make (Schema.KV (Contents.String)) + +let suite = + let store = (module Store : Irmin_test.Generic_key) in + let config = Irmin_mem.config () in + Irmin_test.Suite.create_generic_key ~name:"inlined_contents" ~store ~config + ~import_supported:false () diff --git a/vendors/irmin/test/irmin/generic-key/test_store_offset.ml b/vendors/irmin/test/irmin/generic-key/test_store_offset.ml new file mode 100644 index 0000000000000000000000000000000000000000..3f9d8bdd4cca3cf4b6786d6a27c399ee96c3181b --- /dev/null +++ b/vendors/irmin/test/irmin/generic-key/test_store_offset.ml @@ -0,0 +1,142 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin + +(** A store abstraction over an append-only sequence of values. The key of a + value is the slot at which it's stored in this sequence. There is no index + for finding stored values by their hash, so any sharing must be achieved at + the level of keys. *) +module Slot_keyed_vector : Indexable.Maker_concrete_key1 = struct + type 'h key = { + slot : int; + hash : 'h; + (* Sanity check that keys are used only w/ the stores that created them: *) + store_id : < >; + } + + let key_t hash_t = + let open Type in + let hash_equal = unstage (equal hash_t) in + let hash_pre_hash = unstage (pre_hash hash_t) in + record "key" (fun _ _ -> + Alcotest.fail ~pos:__POS__ "Key implementation is non-serialisable") + |+ field "slot" int (fun t -> t.slot) + |+ field "hash" hash_t (fun t -> t.hash) + |> sealr + |> like (* TODO: write tests that expose the need for these directly *) + ~equal:(fun a b -> hash_equal a.hash b.hash) + ~pre_hash:(fun t f -> hash_pre_hash t.hash f) + + module Key (Hash : Hash.S) = struct + type t = Hash.t key [@@deriving irmin] + type hash = Hash.t + + let to_hash t = t.hash + end + + module Make (Hash : Hash.S) (Value : Type.S) = struct + type instance = { data : (Hash.t * Value.t) option Vector.t; id : < > } + type _ t = { instance : instance option ref } + + let v = + (* NOTE: at time of writing, [irmin-test] relies on the fact that the + store constructor is memoised (modulo [close] semantics, which must be + non-memoised), so we must use a singleton here. *) + let singleton = { data = Vector.create ~dummy:None; id = object end } in + fun _ -> Lwt.return { instance = ref (Some singleton) } + + type nonrec key = Hash.t key [@@deriving irmin] + type value = Value.t + type hash = Hash.t [@@deriving irmin ~equal] + + let index _ _ = Lwt.return_none + + module Key = struct + type t = key [@@deriving irmin] + type hash = Hash.t + + let to_hash t = t.hash + end + + module Hash = Irmin.Hash.Typed (Hash) (Value) + + let check_not_closed t = + match !(t.instance) with None -> raise Closed | Some t -> t + + let check_key_belongs_to_store pos (k : key) (t : instance) = + let key_store_id = k.store_id and expected_id = t.id in + let r = key_store_id == expected_id in + if not r then + Alcotest.(check ~pos int) + "Key ID matches the given store ID" (Oo.id expected_id) + (Oo.id key_store_id) + + let check_hash_is_consistent pos k recovered_hash = + let r = equal_hash k.hash recovered_hash in + if not r then + Alcotest.(check ~pos (Irmin_test.testable Hash.t)) + "Recovered hash is consistent with the key" k.hash recovered_hash + + let unsafe_add t hash v = + let t = check_not_closed t in + Vector.push t.data (Some (hash, v)); + let key = { slot = Vector.length t.data - 1; hash; store_id = t.id } in + Lwt.return key + + let add t v = unsafe_add t (Hash.hash v) v + + let find t k = + let t = check_not_closed t in + check_key_belongs_to_store __POS__ k t; + match Vector.get t.data k.slot with + | exception Not_found -> Lwt.return_none + | None -> + Alcotest.failf "Invalid key slot %d. No data contained here." k.slot + | Some (recovered_hash, data) -> + check_hash_is_consistent __POS__ k recovered_hash; + Lwt.return (Some data) + + let mem t k = + let t = check_not_closed t in + check_key_belongs_to_store __POS__ k t; + assert (k.slot < Vector.length t.data); + Lwt.return_true + + let batch t f = + let _ = check_not_closed t in + f (t :> Perms.read_write t) + + let close t = + t.instance := None; + Lwt.return_unit + end +end + +module Store_maker = Generic_key.Maker (struct + module Contents_store = Indexable.Maker_concrete_key2_of_1 (Slot_keyed_vector) + module Node_store = Slot_keyed_vector + module Commit_store = Slot_keyed_vector + module Branch_store = Atomic_write.Check_closed (Irmin_mem.Atomic_write) +end) + +module Store = Store_maker.Make (Schema.KV (Contents.String)) + +let suite = + let store = (module Store : Irmin_test.Generic_key) in + let config = Irmin_mem.config () in + Irmin_test.Suite.create_generic_key ~name:"store_offset" ~store ~config + ~import_supported:false () diff --git a/vendors/irmin/test/irmin/test.ml b/vendors/irmin/test/irmin/test.ml new file mode 100644 index 0000000000000000000000000000000000000000..377018ec3f537377d353a294ce36f1dda283b58b --- /dev/null +++ b/vendors/irmin/test/irmin/test.ml @@ -0,0 +1,35 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Test_node = Irmin_test.Node.Make (Irmin.Node.Generic_key.Make) + +let lift_suite_to_lwt : + unit Alcotest.test_case list -> unit Alcotest_lwt.test_case list = + List.map (fun (n, s, f) -> (n, s, Fun.const (Lwt.wrap f))) + +let suite = + [ + ("tree", Test_tree.suite); + ("node", Test_node.suite |> lift_suite_to_lwt); + ("hash", Test_hash.suite); + ("conf", Test_conf.suite); + ] + +let () = + Logs.set_level (Some Debug); + Logs.set_reporter (Irmin_test.reporter ()); + Random.self_init (); + Lwt_main.run (Alcotest_lwt.run "irmin" suite) diff --git a/vendors/irmin/test/irmin/test.mli b/vendors/irmin/test/irmin/test.mli new file mode 100644 index 0000000000000000000000000000000000000000..e790aeb70f0d9753901aea2af96010955b2bdddd --- /dev/null +++ b/vendors/irmin/test/irmin/test.mli @@ -0,0 +1 @@ +(* empty *) diff --git a/vendors/irmin/test/irmin/test_conf.ml b/vendors/irmin/test/irmin/test_conf.ml new file mode 100644 index 0000000000000000000000000000000000000000..f8b34e7f4f41d074cf68b73b331c75956ee5deed --- /dev/null +++ b/vendors/irmin/test/irmin/test_conf.ml @@ -0,0 +1,46 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Backend.Conf + +let test_conf () = + let spec_a = Spec.v "a" in + let spec_b = Spec.v "b" in + let x = key ~spec:spec_a "x" Irmin.Type.int 0 in + let _y = key ~spec:spec_a "y" Irmin.Type.int 1 in + let conf_a = add (empty spec_a) x 1 in + let () = Alcotest.(check int) "x" 1 (get conf_a x) in + let () = + Alcotest.check_raises "Wrong spec" + (Invalid_argument "invalid config key: x") (fun () -> + ignore (add (empty spec_b) x 1)) + in + let specs = + Spec.list () |> Seq.map Spec.name |> List.of_seq |> List.sort String.compare + in + let () = + Alcotest.(check (list string)) "Spec list" [ "a"; "b"; "mem" ] specs + in + let keys = + Spec.keys spec_a + |> Seq.map (fun (K k) -> name k) + |> List.of_seq + |> List.sort String.compare + in + let () = Alcotest.(check (list string)) "Key list" [ "x"; "y" ] keys in + () + +let suite = [ Alcotest_lwt.test_case_sync "conf" `Quick test_conf ] diff --git a/vendors/irmin/test/irmin/test_conf.mli b/vendors/irmin/test/irmin/test_conf.mli new file mode 100644 index 0000000000000000000000000000000000000000..3258b5f81c754bb899dac72d6dba424b0abbdb51 --- /dev/null +++ b/vendors/irmin/test/irmin/test_conf.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val suite : unit Alcotest_lwt.test_case list diff --git a/vendors/irmin/test/irmin/test_hash.ml b/vendors/irmin/test/irmin/test_hash.ml new file mode 100644 index 0000000000000000000000000000000000000000..ce653b0b3cf76c88b7921541b5e72b54cd54007d --- /dev/null +++ b/vendors/irmin/test/irmin/test_hash.ml @@ -0,0 +1,37 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin + +let test_short_hash () = + let h = Hash.BLAKE2B.hash (fun f -> f "") in + let () = + Hash.BLAKE2B.short_hash h + |> Alcotest.(check int) + "Specialised short hash" + (Int64.to_int 241225442164632184L) + in + let () = + Type.(unstage (short_hash Hash.BLAKE2B.t)) ~seed:0 h + |> Alcotest.(check int) "Generic seeded short hash" 674923654 + in + let () = + Type.(unstage (short_hash Hash.BLAKE2B.t)) ?seed:None h + |> Alcotest.(check int) "Generic unseeded short hash" 674923654 + in + () + +let suite = [ Alcotest_lwt.test_case_sync "short_hash" `Quick test_short_hash ] diff --git a/vendors/irmin/test/irmin/test_hash.mli b/vendors/irmin/test/irmin/test_hash.mli new file mode 100644 index 0000000000000000000000000000000000000000..3258b5f81c754bb899dac72d6dba424b0abbdb51 --- /dev/null +++ b/vendors/irmin/test/irmin/test_hash.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val suite : unit Alcotest_lwt.test_case list diff --git a/vendors/irmin/test/irmin/test_tree.ml b/vendors/irmin/test/irmin/test_tree.ml new file mode 100644 index 0000000000000000000000000000000000000000..ed4d3ee42b7f8be36f9104588b3bbecba6f993bc --- /dev/null +++ b/vendors/irmin/test/irmin/test_tree.ml @@ -0,0 +1,857 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Irmin.Export_for_backends +open Irmin + +module Metadata = struct + type t = Default | Left | Right [@@deriving irmin] + + let merge = + Merge.v t (fun ~old:_ _ _ -> Merge.conflict "Can't merge metadata") + + let default = Default +end + +module Schema = struct + module Metadata = Metadata + module Contents = Contents.String + module Path = Path.String_list + module Branch = Branch.String + module Hash = Hash.BLAKE2B + module Node = Node.Generic_key.Make (Hash) (Path) (Metadata) + module Commit = Commit.Make (Hash) + module Info = Info.Default +end + +module Store = Irmin_mem.Make (Schema) +module Tree = Store.Tree +open Schema + +type diffs = (string list * (Contents.t * Metadata.t) Diff.t) list +[@@deriving irmin] + +type kind = [ `Contents | `Node ] [@@deriving irmin] + +module Alcotest = struct + include Alcotest + + let gtestable typ = testable (Type.pp_dump typ) Type.(unstage (equal typ)) + let gcheck typ = check (gtestable typ) + let diffs = gtestable diffs_t + let assert_ msg b = check bool msg true b + + let check_tree_lwt = + let concrete_tree = gtestable Tree.concrete_t in + fun ?__POS__:pos msg ~expected b_lwt -> + b_lwt + >>= Tree.to_concrete + >|= Alcotest.check ?pos concrete_tree msg expected + + let inspect = + Alcotest.testable + (fun ppf -> function + | `Contents -> Fmt.string ppf "contents" + | `Node `Key -> Fmt.string ppf "key" + | `Node `Map -> Fmt.string ppf "map" + | `Node `Value -> Fmt.string ppf "value" + | `Node `Portable_dirty -> Fmt.string ppf "portable_dirty" + | `Node `Pruned -> Fmt.string ppf "pruned") + ( = ) +end + +let check_exn_lwt ~exn_type pos f = + Lwt.catch + (fun () -> + let* _ = f () in + Alcotest.failf ~pos + "Expected a `%s` exception, but no exception was raised." + (match exn_type with + | `Dangling_hash -> "Dangling_hash" + | `Pruned_hash -> "Pruned_hash")) + (fun exn -> + match (exn_type, exn) with + | `Dangling_hash, Tree.Dangling_hash _ -> Lwt.return_unit + | `Pruned_hash, Tree.Pruned_hash _ -> Lwt.return_unit + | _ -> Lwt.fail exn) + +(* Let-syntax for testing all possible combinations of a set of choices: *) +let ( let&* ) x f = Lwt_list.iter_s f x +and ( and&* ) l m = List.concat_map (fun a -> List.map (fun b -> (a, b)) m) l + +let ( >> ) f g x = g (f x) +let c ?(info = Metadata.default) blob = `Contents (blob, info) + +let invalid_tree () = + let+ repo = Store.Repo.v (Irmin_mem.config ()) in + let hash = Store.Hash.hash (fun f -> f "") in + Tree.shallow repo (`Node hash) + +let test_bindings _ () = + let tree = + Tree.of_concrete + (`Tree [ ("aa", c "0"); ("ab", c "1"); ("a", c "2"); ("b", c "3") ]) + in + let check_sorted = + Alcotest.(check (list string)) + "Bindings are reported in lexicographic order" [ "a"; "aa"; "ab"; "b" ] + in + (* [Tree.list] returns all keys in lexicographic order *) + Tree.list tree [] >|= (List.map fst >> check_sorted) + +let test_paginated_bindings _ () = + let tree = + Tree.of_concrete + (`Tree + [ + ("aa", c "0"); + ("a", c "1"); + ("bbb", c "3"); + ("b", c "3"); + ("aaa", c "2"); + ]) + in + let check_sorted expected = + Alcotest.(check (list string)) + "Bindings are reported in lexicographic order" expected + in + let* () = + Tree.list ~offset:0 ~length:2 tree [] + >|= (List.map fst >> check_sorted [ "a"; "aa" ]) + in + let* () = + Tree.list ~offset:2 ~length:3 tree [] + >|= (List.map fst >> check_sorted [ "aaa"; "b"; "bbb" ]) + in + let* () = + Tree.list ~offset:1 ~length:1 tree [] + >|= (List.map fst >> check_sorted [ "aa" ]) + in + let* () = + Tree.list ~offset:4 ~length:2 tree [] + >|= (List.map fst >> check_sorted [ "bbb" ]) + in + let* () = + Tree.list ~offset:5 ~length:2 tree [] >|= (List.map fst >> check_sorted []) + in + Lwt.return_unit + +let tree bs = Tree.of_concrete (`Tree bs) + +(** Basic tests of the [Tree.diff] operation. *) +let test_diff _ () = + let empty = tree [] in + let single = tree [ ("k", c "v") ] in + + (* Adding a single key *) + let* () = + Tree.diff empty single + >|= Alcotest.(check diffs) + "Added [k \226\134\146 v]" + [ ([ "k" ], `Added ("v", Default)) ] + in + (* Removing a single key *) + let* () = + Tree.diff single empty + >|= Alcotest.(check diffs) + "Removed [k \226\134\146 v]" + [ ([ "k" ], `Removed ("v", Default)) ] + in + (* Changing metadata *) + Tree.diff + (tree [ ("k", c ~info:Left "v") ]) + (tree [ ("k", c ~info:Right "v") ]) + >|= Alcotest.(check diffs) + "Changed metadata" + [ ([ "k" ], `Updated (("v", Left), ("v", Right))) ] + +let test_empty _ () = + let* () = + Alcotest.check_tree_lwt "The empty tree is empty" ~expected:(`Tree []) + (Lwt.return (Tree.empty ())) + in + + (* Ensure that different [empty] values have disjoint cache state. + + This is a regression test for a bug in which all [Tree.empty] values had + shared cache state and any keys obtained from [export] were discarded (to + avoid sharing keys from different repositories). *) + let* () = + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let empty_exported = Tree.empty () and empty_not_exported = Tree.empty () in + let+ () = + Store.Backend.Repo.batch repo (fun c n _ -> + Store.save_tree repo c n empty_exported >|= ignore) + in + Alcotest.(check inspect) + "The exported empty tree is now in Key form" (`Node `Key) + (Tree.inspect empty_exported); + Alcotest.(check inspect) + "The non-exported empty tree should still be represented as a Map" + (`Node `Map) + (Tree.inspect empty_not_exported) + in + + Lwt.return_unit + +let test_add _ () = + let sample_tree ?(ab = "ab_v") ?ac () : Tree.concrete = + let ac = match ac with Some ac -> [ ("ac", ac) ] | None -> [] in + `Tree [ ("a", `Tree ([ ("aa", c "0"); ("ab", c ab) ] @ ac)); ("b", c "3") ] + in + + let* () = + Alcotest.check_tree_lwt "Adding a root value to an empty tree" + ~expected:(c "1") + (Tree.add (Tree.empty ()) [] "1") + in + + let* () = + let t = Tree.of_concrete (sample_tree ()) in + let expected = sample_tree ~ab:"new_value" () in + Alcotest.check_tree_lwt "Replacing an existing value in a tree" ~expected + (Tree.add t [ "a"; "ab" ] "new_value") + in + + let* () = + let t = Tree.of_concrete (sample_tree ()) in + let expected = sample_tree ~ac:(`Tree [ ("aca", c "new_value") ]) () in + Alcotest.check_tree_lwt + "Adding at a non-existent path in a tree creates necessary intermediate \ + nodes" + ~expected + (Tree.add t [ "a"; "ac"; "aca" ] "new_value") + in + + let* () = + let t = Tree.of_concrete (c "1") in + let+ t' = Tree.add t [] "1" in + Alcotest.assert_ "Re-adding a root value preserves physical equality" + (t == t') + in + + let* () = + let t = tree [ ("a", `Tree [ ("b", c "1") ]) ] in + let+ t' = Tree.add t [ "a"; "b" ] "1" in + Alcotest.assert_ "Re-adding a non-root value preserves physical equality" + (t == t') + in + + Lwt.return_unit + +let test_remove _ () = + let tree = + Tree.of_concrete + (`Tree [ ("a", `Tree [ ("aa", c "0"); ("ab", c "1") ]); ("b", c "3") ]) + in + + let* () = + let t = Tree.empty () in + let+ t' = Tree.remove t [] in + Alcotest.assert_ "Removing in an empty tree preserves physical equality" + (t == t') + in + + let* () = + let+ tree' = Tree.remove tree [ "a"; "non"; "existent"; "path" ] in + Alcotest.assert_ + "Removing at a non-existent path in a non-empty tree preserves physical \ + equality" + (tree == tree') + in + + let* () = + let tree = Tree.of_concrete (c "1") in + let+ tree' = Tree.remove tree [ "a"; "non"; "existent"; "path" ] in + Alcotest.assert_ + "Removing at a non-existent path in a root contents value preserves \ + physical equality" + (tree == tree') + in + + let* () = + Alcotest.check_tree_lwt + "Removing a root contents value results in an empty root node." + ~expected:(`Tree []) + (Tree.remove (Tree.of_concrete (c "1")) []) + in + + Lwt.return_unit + +(* Build a function that requires a given input, always returns a given output, + and can be called at most once. *) +let transform_once : type a b. a Type.t -> a -> b -> a -> b = + fun typ -> + let equal = Type.(unstage (equal typ)) in + let pp = Type.pp_dump typ in + fun source target -> + let called = ref false in + fun x -> + if !called then Alcotest.failf "Transformation called more than once"; + called := true; + if equal source x then target + else Alcotest.failf "Expected %a but got %a" pp source pp x + +let test_update _ () = + let unrelated_binding = ("a_unrelated", c "<>") in + let abc ?info v = + `Tree + [ ("a", `Tree [ ("b", `Tree [ ("c", c ?info v) ]) ]); unrelated_binding ] + in + let abc1 = Tree.of_concrete (abc "1") in + let ( --> ) = transform_once [%typ: string option] in + + let* () = + Alcotest.check_tree_lwt + "Changing the value of a root contents node results in a new contents \ + node." + ~expected:(c "2") + (Tree.update (Tree.of_concrete (c "1")) [] (Some "1" --> Some "2")) + in + + let* () = + Alcotest.check_tree_lwt + "Removing a root contents node results in an empty root node." + ~expected:(`Tree []) + (Tree.update (Tree.of_concrete (c "1")) [] (Some "1" --> None)) + in + + let* () = + Alcotest.check_tree_lwt + "Updating a root node to a contents value removes all bindings and sets \ + the correct metadata." + ~expected:(c ~info:Metadata.Right "2") + (Tree.update ~metadata:Metadata.Right abc1 [] (None --> Some "2")) + in + + let* () = + (* Replacing a root node with a dangling hash does not raise an + exception. *) + let* invalid_tree = invalid_tree () in + Tree.update_tree abc1 [] (function + | Some _ -> Some invalid_tree + | None -> assert false) + >|= ignore + in + + let* () = + Alcotest.check_tree_lwt + "Updating at an existing contents path changes the contents value \ + appropriately." + ~expected:(abc "2") + (Tree.update abc1 [ "a"; "b"; "c" ] (Some "1" --> Some "2")) + in + + let* () = + let s = "1" and s' = "1" ^ "" in + assert (s != s'); + let+ abc1' = Tree.update abc1 [ "a"; "b"; "c" ] (Some s --> Some s') in + Alcotest.assert_ + "Performing a no-op change to tree contents preserves physical equality" + (abc1 == abc1') + in + + let* () = + let+ abc1' = + Tree.update_tree abc1 [ "a"; "b" ] (function + | Some t -> Some t + | None -> assert false) + in + Alcotest.assert_ + "Replacing a subtree node with a physically-equal one preserves physical \ + equality" + (abc1 == abc1') + in + + let* () = + Alcotest.check_tree_lwt + "Changing the metadata of an existing contents value updates the tree." + ~expected:(abc ~info:Metadata.Left "1") + (Tree.update ~metadata:Metadata.Left abc1 [ "a"; "b"; "c" ] + (Some "1" --> Some "1")) + in + + let* () = + Alcotest.check_tree_lwt + "Removing a siblingless contents value causes newly-empty directories to \ + be pruned." + ~expected:(`Tree [ unrelated_binding ]) + (Tree.update abc1 [ "a"; "b"; "c" ] (Some "1" --> None)) + in + + let* () = + Alcotest.check_tree_lwt + "Removing a siblingless node causes newly-empty directories to be pruned" + ~expected:(`Tree [ unrelated_binding ]) + (Tree.update_tree abc1 [ "a"; "b" ] (function + | Some _ -> None + | None -> assert false)) + in + + let* () = + Alcotest.check_tree_lwt + "Updating at a non-existent contents path adds a new directory entry." + ~expected: + (`Tree + [ + ("a", `Tree [ ("b", `Tree [ ("c", c "1"); ("c'", c "new_value") ]) ]); + unrelated_binding; + ]) + (Tree.update abc1 [ "a"; "b"; "c'" ] (None --> Some "new_value")) + in + + let* () = + Alcotest.check_tree_lwt + "Updating at an existing node path replaces the subtree with the given \ + element." + ~expected: + (`Tree [ ("a", `Tree [ ("b", c "new_value") ]); unrelated_binding ]) + (Tree.update abc1 [ "a"; "b" ] (None --> Some "new_value")) + in + + let* () = + Alcotest.check_tree_lwt + "Updating at a path in an empty tree creates the necessary intermediate \ + nodes with the new contents." + ~expected:(`Tree [ ("a", `Tree [ ("b", `Tree [ ("c", c "1") ]) ]) ]) + (Tree.update (Tree.empty ()) [ "a"; "b"; "c" ] (None --> Some "1")) + in + + let* () = + let+ abc1' = Tree.update abc1 [ "a"; "b"; "c"; "d"; "e" ] (None --> None) in + Alcotest.assert_ + "Removing at a non-existent path in a non-empty tree preserves physical \ + equality." + (abc1 == abc1') + in + + let* () = + let t = Tree.empty () in + let+ t' = Tree.update t [] (None --> None) in + Alcotest.assert_ "Removing from an empty tree preserves physical equality" + (t == t') + in + + let* () = + let+ abc1' = + Tree.update_tree abc1 [ "a"; "b"; "d" ] (function + | None -> Some (Tree.empty ()) + | Some _ -> assert false) + in + Alcotest.assert_ + "Adding an empty tree at an empty location preserves physical equality" + (abc1 == abc1') + in + + Lwt.return_unit + +(* Correct stats for a completely lazy tree *) +let lazy_stats = Tree.{ nodes = 0; leafs = 0; skips = 1; depth = 0; width = 0 } + +(* Take a tree and persist it to some underlying store, making it lazy. *) +let persist_tree : Store.tree -> Store.tree Lwt.t = + fun tree -> + let* store = Store.Repo.v (Irmin_mem.config ()) >>= Store.empty in + let* () = Store.set_tree_exn ~info:Store.Info.none store [] tree in + Store.tree store + +type path = Store.Path.t [@@deriving irmin ~pp ~equal] + +let test_clear _ () = + (* 1. Build a tree *) + let size = 830829 in + let* t = + List.init size string_of_int + |> Lwt_list.fold_left_s (fun acc i -> Tree.add acc [ i ] i) (Tree.empty ()) + in + (* Check the state of the root and root/42 *) + Alcotest.(check inspect) "Before clear, root" (`Node `Map) (Tree.inspect t); + let* () = + Tree.stats ~force:false t + >|= Alcotest.(gcheck Tree.stats_t) + "Before clear, root node is eagerly evaluated" + { nodes = 1; leafs = size; skips = 0; depth = 1; width = size } + in + let* entry42 = Tree.find_tree t [ "42" ] >|= Option.get in + Alcotest.(check inspect) + "Before clear, root/42" `Contents (Tree.inspect entry42); + let* () = + let dont_skip k = Alcotest.failf "should not have skipped %a" pp_path k in + Tree.fold ~force:(`False dont_skip) entry42 () + in + (* 2. Clear on non-persisted *) + Tree.clear t; + (* The state of the tree shouldn't have changed after this clear *) + Alcotest.(check inspect) "Before persist" (`Node `Map) (Tree.inspect t); + let* () = + Tree.stats ~force:false t + >|= Alcotest.(gcheck Tree.stats_t) + "Before persist, root node is eagerly evaluated" + { nodes = 1; leafs = size; skips = 0; depth = 1; width = size } + in + let* entry42 = Tree.find_tree t [ "42" ] >|= Option.get in + Alcotest.(check inspect) "Before persist" `Contents (Tree.inspect entry42); + let* () = + let dont_skip k = Alcotest.failf "should not have skipped %a" pp_path k in + Tree.fold ~force:(`False dont_skip) entry42 () + in + (* 3. Persist (and implicitly clear) *) + let* _ = persist_tree t in + (* Check the state of the root *) + Alcotest.(check inspect) "After persist+clear" (`Node `Key) (Tree.inspect t); + let* () = + Tree.stats ~force:false t + >|= Alcotest.(gcheck Tree.stats_t) + "After persist+clear, root node is no longer cached" lazy_stats + in + Lwt.return_unit + +let with_binding k v t = Tree.add_tree t k v + +let clear_and_assert_lazy tree = + let* _ = persist_tree tree in + Tree.clear tree; + Tree.stats ~force:false tree + >|= Alcotest.(gcheck Tree.stats_t) + "Initially the tree is entirely lazy" lazy_stats + +let test_fold_force _ () = + let* invalid_tree = + let+ repo = Store.Repo.v (Irmin_mem.config ()) in + let hash = Store.Hash.hash (fun f -> f "") in + Tree.shallow repo (`Node hash) + in + + (* Ensure that [fold] doesn't force a lazy tree when [~force:(`False f)], + and that [f] is called the correct number of times. *) + let* () = + let* tree = + Tree.singleton [ "existing"; "subtree" ] "value" + |> with_binding [ "dangling"; "subtree"; "hash" ] invalid_tree + >>= with_binding [ "other"; "lazy"; "path" ] invalid_tree + in + let force = `False (Lwt.wrap2 List.cons) in + Tree.fold ~force tree [] + >|= Alcotest.(check (slist (list string) Stdlib.compare)) + "Unforced paths" + [ [ "dangling"; "subtree"; "hash" ]; [ "other"; "lazy"; "path" ] ] + in + let create_sample_tree () = + Tree.of_concrete + (`Tree + [ + ("a", `Tree [ ("aa", c "v-aa"); ("ab", c "v-ab"); ("ac", c "v-ac") ]); + ("b", c "v-b"); + ("c", c "v-c"); + ]) + in + let eager_stats = + Tree.{ nodes = 2; leafs = 5; skips = 0; depth = 2; width = 3 } + in + + (* Ensure that [fold ~force:`True ~cache:true] forces all lazy trees. *) + let* () = + let sample_tree = create_sample_tree () in + let* () = clear_and_assert_lazy sample_tree in + Tree.fold ~force:`True ~cache:true sample_tree () >>= fun () -> + Tree.stats ~force:false sample_tree + >|= Alcotest.(gcheck Tree.stats_t) + "After folding, the tree is eagerly evaluated" eager_stats + in + + (* Ensure that [fold ~force:`True ~cache:false] visits all children and does + not leave them cached. *) + let* () = + let sample_tree = create_sample_tree () in + clear_and_assert_lazy sample_tree >>= fun () -> + let* contents = + Tree.fold ~force:`True ~cache:false + ~contents:(fun _ -> Lwt.wrap2 List.cons) + sample_tree [] + in + let+ () = + Tree.stats ~force:false sample_tree + >|= Alcotest.(gcheck Tree.stats_t) + "After folding, the tree is cleared" lazy_stats + in + Alcotest.(check (slist string compare)) + "During forced fold, all contents were traversed" + [ "v-aa"; "v-ab"; "v-ac"; "v-b"; "v-c" ] + contents + in + + (* Ensure that [fold ~force:`True ~cache:false] visits newly added values and + updated values only once and does not visit removed values. *) + let* () = + let sample_tree = create_sample_tree () in + let* () = clear_and_assert_lazy sample_tree in + Tree.remove sample_tree [ "a"; "ab" ] >>= fun updated_tree -> + Tree.add updated_tree [ "a"; "ad" ] "v-ad" >>= fun updated_tree -> + Tree.add updated_tree [ "a"; "ac" ] "v-acc" >>= fun updated_tree -> + let visited = ref [] in + let contents k v () = + if equal_path k [ "a"; "ab" ] then + Alcotest.failf + "Removed contents at %a should not be visited during fold" pp_path k; + if equal_path k [ "a"; "ac" ] then + if not (String.equal v "v-acc") then + Alcotest.failf "Outdated contents at %a visited during fold" pp_path k; + if List.mem ~equal:equal_path k !visited then + Alcotest.failf "Visited node at %a twice during fold" pp_path k + else visited := k :: !visited; + Lwt.return_unit + in + Tree.fold ~force:`True ~cache:false ~contents updated_tree () >|= fun () -> + Alcotest.(check bool) + "Newly added contents visited" + (List.mem ~equal:equal_path [ "a"; "ad" ] !visited) + true + in + + Lwt.return_unit + +(* Tests of "broken" trees: trees that can't be dereferenced. Tree currently + supports two varieties of broken tree: + + - shallow trees containing [(repo, key)] pairs for which [repo] doesn't + contain [key]. Attempted dereferences should raise [Dangling_hash]. + + - pruned trees (hash-only tree nodes, with no underlying repository). + Attempted dereferences should raise [Pruned_hash]. *) +module Broken = struct + let shallow_of_ptr kinded_key = + let+ repo = Store.Repo.v (Irmin_mem.config ()) in + Tree.shallow repo kinded_key + + let pruned_of_ptr kinded_hash = Lwt.return (Tree.pruned kinded_hash) + let random_string32 = Irmin.Type.(unstage (random (string_of (`Fixed 32)))) + + let random_contents () = + let value = Tree.of_concrete (c (random_string32 ())) in + let value_ptr = `Contents (Tree.hash value, Metadata.default) in + (value, value_ptr) + + let random_node () = + let value = tree [ ("k", c (random_string32 ())) ] in + let value_ptr = `Node (Tree.hash value) in + (value, value_ptr) + + let test_hashes _ () = + let&* leaf_type, (leaf, leaf_ptr) = + [ ("contents", random_contents ()); ("node", random_node ()) ] + and&* operation_name, operation = + [ ("shallow", shallow_of_ptr); ("pruned", pruned_of_ptr) ] + and&* path = [ []; [ "k" ] ] in + let* leaf_broken = operation leaf_ptr in + let* hash_actual = Tree.(add_tree (empty ())) path leaf >|= Tree.hash in + let+ hash_expected = + Tree.(add_tree (empty ())) path leaf_broken >|= Tree.hash + in + Alcotest.(gcheck Store.Hash.t) + (Fmt.str + "Hashing a %s %s value at path %a is equivalent to hashing the \ + non-broken %s" + operation_name leaf_type + Fmt.Dump.(list string) + path leaf_type) + hash_expected hash_actual + + let test_trees _ () = + let run_tests ~exn_type ~broken_contents ~broken_node ~path = + [%logs.app + "Testing operations on a tree with a broken position at %a" pp_path path]; + let* broken_leaf = Tree.(add_tree (empty ())) path broken_contents in + let* broken_node = Tree.(add_tree (empty ())) path broken_node in + let beneath = path @ [ "a"; "b"; "c" ] in + let blob = "v" and node = tree [ ("k", c "v") ] in + let add_blob_or_node path = + [ + (fun tr -> Tree.(add tr path blob)); + (fun tr -> Tree.(add_tree tr path node)); + ] + in + + (* [add] on broken nodes/contents replaces the broken position. *) + let* () = + let&* broken = [ broken_leaf; broken_node ] + and&* add = add_blob_or_node path in + let* expected = add (Tree.empty ()) >>= Tree.to_concrete in + Alcotest.check_tree_lwt ~__POS__ "" ~expected (add broken) + in + + (* [add] _beneath_ a broken contents value also works fine, but on broken + nodes an exception is raised. (We can't know what the node's contents are, + so there's no valid return tree.) *) + let* () = + let&* add_beneath = add_blob_or_node beneath in + let* expected = add_beneath (Tree.empty ()) >>= Tree.to_concrete in + Alcotest.check_tree_lwt ~__POS__ "" ~expected (add_beneath broken_leaf) + in + let* () = + let&* add_beneath = add_blob_or_node beneath in + check_exn_lwt ~exn_type __POS__ (fun () -> add_beneath broken_node) + in + + (* [find] on broken contents raises an exception (can't recover contents), + but _beneath_ broken contents it returns [None] (mismatched type). (The + behaviour is reversed for broken nodes.) *) + let* () = + check_exn_lwt ~exn_type __POS__ (fun () -> Tree.find broken_leaf path) + in + let* () = + check_exn_lwt ~exn_type __POS__ (fun () -> + Tree.find broken_node beneath) + in + let* () = + Tree.find broken_leaf beneath + >|= Alcotest.(check ~pos:__POS__ (option reject)) "" None + in + let* () = + Store.Tree.find broken_node path + >|= Alcotest.(check ~pos:__POS__ (option reject)) "" None + in + + (* [list] on (or beneath) broken contents returns the empty list, but on + (or beneath) broken nodes an exception is raised. *) + let* () = + let&* path = [ path; beneath ] in + Tree.list broken_leaf path + >|= Alcotest.(check ~pos:__POS__ (list reject)) "" [] + in + let* () = + let&* path = [ path; beneath ] in + check_exn_lwt ~exn_type __POS__ (fun () -> Tree.list broken_node path) + in + Lwt.return_unit + in + let&* path = [ []; [ "k" ] ] + and&* exn_type, tree_of_ptr = + [ (`Dangling_hash, shallow_of_ptr); (`Pruned_hash, pruned_of_ptr) ] + in + let* broken_contents = tree_of_ptr (snd (random_contents ())) in + let* broken_node = tree_of_ptr (snd (random_node ())) in + run_tests ~exn_type ~broken_contents ~broken_node ~path + + let test_pruned_fold _ () = + let&* _, ptr = [ random_contents (); random_node () ] + and&* path = [ []; [ "k" ] ] in + let* tree = Tree.(add_tree (empty ())) path (Tree.pruned ptr) in + + (* Folding over a pruned tree with [force:`True] should fail: *) + let* () = + check_exn_lwt ~exn_type:`Pruned_hash __POS__ (fun () -> + Tree.fold ~force:`True tree ()) + in + + (* But folding with [force:`False] should not: *) + let* () = Tree.fold ~force:(`False (fun _ -> Lwt.return)) tree () in + + (* Similarly, attempting to export a pruned tree should fail: *) + let* repo = Store.Repo.v (Irmin_mem.config ()) in + check_exn_lwt ~exn_type:`Pruned_hash __POS__ (fun () -> + Store.Backend.Repo.batch repo (fun c n _ -> + Store.save_tree repo c n tree >|= ignore)) +end + +let test_kind_empty_path _ () = + let cont = c "c" |> Tree.of_concrete in + let tree = `Tree [ ("k", c "c") ] |> Tree.of_concrete in + let* k = Tree.kind cont [] in + Alcotest.(check (option (gtestable kind_t))) + "Kind of empty path in content" (Some `Contents) k; + let* k = Tree.kind tree [] in + Alcotest.(check (option (gtestable kind_t))) + "Kind of empty path in tree" (Some `Node) k; + Lwt.return_unit + +let test_generic_equality _ () = + (* Regression test for a bug in which the equality derived from [tree_t] did + not respect equivalences between in-memory trees and lazy trees. *) + let* tree = persist_tree (tree [ ("k", c "v") ]) in + let+ should_be_empty = Tree.remove tree [ "k" ] in + Alcotest.(gcheck Store.tree_t) + "Modified empty tree is equal to [(Tree.empty ())]" (Tree.empty ()) + should_be_empty + +let test_is_empty _ () = + (* Test for equivalence against an [is_equal] derived from generic equality, + for backwards compatibility. *) + let is_empty = + let equal = Type.unstage (Type.equal Store.tree_t) in + fun t -> + let reference = equal t (Tree.empty ()) in + let candidate = Tree.is_empty t in + Alcotest.(check bool) + "`equal (Tree.empty ())` agrees with `is_empty`" reference candidate; + candidate + in + let kv = tree [ ("k", c "v") ] in + let () = Alcotest.(check bool) "empty tree" true (is_empty (Tree.empty ())) in + let () = Alcotest.(check bool) "non-empty tree" false (is_empty kv) in + let* () = + let+ tree = Tree.remove kv [ "k" ] in + Alcotest.(check bool) "emptied tree" true (is_empty tree) + in + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let () = + let shallow_empty = Tree.(shallow repo (`Node (hash (empty ())))) in + Alcotest.(check bool) "shallow empty tree" true (is_empty shallow_empty) + in + let () = + let shallow_empty = Tree.(shallow repo (`Node (hash kv))) in + Alcotest.(check bool) + "shallow non-empty tree" false (is_empty shallow_empty) + in + Lwt.return_unit + +let test_of_concrete _ () = + let* () = + let aa = ("aa", c "aa-v") in + let ac = ("ac", c "ac-v") in + let input = tree [ ("a", `Tree [ aa; ("ab", `Tree []); ac ]) ] in + let pruned = `Tree [ ("a", `Tree [ aa; ac ]) ] in + Alcotest.check_tree_lwt "Empty subtrees are pruned" ~expected:pruned + (Tree.to_concrete input >|= Tree.of_concrete) + in + + let () = + Alcotest.check_raises "Tree with duplicate bindings is rejected" + (Invalid_argument "of_concrete: duplicate bindings for step `k`") + (fun () -> + ignore (Tree.of_concrete (`Tree [ ("k", c "v1"); ("k", c "v2") ]))) + in + + Lwt.return_unit + +let suite = + [ + Alcotest_lwt.test_case "bindings" `Quick test_bindings; + Alcotest_lwt.test_case "paginated bindings" `Quick test_paginated_bindings; + Alcotest_lwt.test_case "diff" `Quick test_diff; + Alcotest_lwt.test_case "empty" `Quick test_empty; + Alcotest_lwt.test_case "add" `Quick test_add; + Alcotest_lwt.test_case "remove" `Quick test_remove; + Alcotest_lwt.test_case "update" `Quick test_update; + Alcotest_lwt.test_case "clear" `Quick test_clear; + Alcotest_lwt.test_case "fold" `Quick test_fold_force; + Alcotest_lwt.test_case "Broken.hashes" `Quick Broken.test_hashes; + Alcotest_lwt.test_case "Broken.trees" `Quick Broken.test_trees; + Alcotest_lwt.test_case "Broken.pruned_fold" `Quick Broken.test_pruned_fold; + Alcotest_lwt.test_case "kind of empty path" `Quick test_kind_empty_path; + Alcotest_lwt.test_case "generic equality" `Quick test_generic_equality; + Alcotest_lwt.test_case "is_empty" `Quick test_is_empty; + Alcotest_lwt.test_case "of_concrete" `Quick test_of_concrete; + ] diff --git a/vendors/irmin/test/irmin/test_tree.mli b/vendors/irmin/test/irmin/test_tree.mli new file mode 100644 index 0000000000000000000000000000000000000000..3258b5f81c754bb899dac72d6dba424b0abbdb51 --- /dev/null +++ b/vendors/irmin/test/irmin/test_tree.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val suite : unit Alcotest_lwt.test_case list diff --git a/vendors/irmin/test/libirmin/dune b/vendors/irmin/test/libirmin/dune new file mode 100644 index 0000000000000000000000000000000000000000..d71a6fa7822bb1190b152fc8b3050eb6aaad21f4 --- /dev/null +++ b/vendors/irmin/test/libirmin/dune @@ -0,0 +1,27 @@ +(rule + (alias runtest) + (package libirmin) + (action + (setenv + DYLD_FALLBACK_LIBRARY_PATH + ../../src/libirmin/lib + (setenv + LD_LIBRARY_PATH + ../../src/libirmin/lib + (run ./test.exe))))) + +(rule + (targets test.exe) + (deps + (file test.c) + (file greatest.h) + (package libirmin)) + (action + (run + %{cc} + -I../../src/libirmin/lib + -o + test.exe + test.c + -L../../src/libirmin/lib + -lirmin))) diff --git a/vendors/irmin/test/libirmin/greatest.h b/vendors/irmin/test/libirmin/greatest.h new file mode 100644 index 0000000000000000000000000000000000000000..4c2b3f2d93dabe6924c9e9ef08158586fc3fd001 --- /dev/null +++ b/vendors/irmin/test/libirmin/greatest.h @@ -0,0 +1,1290 @@ +/* + * Copyright (c) 2011-2021 Scott Vokes + * + * Permission to use, copy, modify, and/or distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + */ + +#ifndef GREATEST_H +#define GREATEST_H + +#if defined(__cplusplus) && !defined(GREATEST_NO_EXTERN_CPLUSPLUS) +extern "C" { +#endif + +/* 1.5.0 */ +#define GREATEST_VERSION_MAJOR 1 +#define GREATEST_VERSION_MINOR 5 +#define GREATEST_VERSION_PATCH 0 + +/* A unit testing system for C, contained in 1 file. + * It doesn't use dynamic allocation or depend on anything + * beyond ANSI C89. + * + * An up-to-date version can be found at: + * https://github.com/silentbicycle/greatest/ + */ + +/********************************************************************* + * Minimal test runner template + *********************************************************************/ +#if 0 + +#include "greatest.h" + +TEST foo_should_foo(void) { + PASS(); +} + +static void setup_cb(void *data) { + printf("setup callback for each test case\n"); +} + +static void teardown_cb(void *data) { + printf("teardown callback for each test case\n"); +} + +SUITE(suite) { + /* Optional setup/teardown callbacks which will be run before/after + * every test case. If using a test suite, they will be cleared when + * the suite finishes. */ + SET_SETUP(setup_cb, voidp_to_callback_data); + SET_TEARDOWN(teardown_cb, voidp_to_callback_data); + + RUN_TEST(foo_should_foo); +} + +/* Add definitions that need to be in the test runner's main file. */ +GREATEST_MAIN_DEFS(); + +/* Set up, run suite(s) of tests, report pass/fail/skip stats. */ +int run_tests(void) { + GREATEST_INIT(); /* init. greatest internals */ + /* List of suites to run (if any). */ + RUN_SUITE(suite); + + /* Tests can also be run directly, without using test suites. */ + RUN_TEST(foo_should_foo); + + GREATEST_PRINT_REPORT(); /* display results */ + return greatest_all_passed(); +} + +/* main(), for a standalone command-line test runner. + * This replaces run_tests above, and adds command line option + * handling and exiting with a pass/fail status. */ +int main(int argc, char **argv) { + GREATEST_MAIN_BEGIN(); /* init & parse command-line args */ + RUN_SUITE(suite); + GREATEST_MAIN_END(); /* display results */ +} + +#endif +/*********************************************************************/ + +#include +#include +#include +#include + +/*********** + * Options * + ***********/ + +/* Default column width for non-verbose output. */ +#ifndef GREATEST_DEFAULT_WIDTH +#define GREATEST_DEFAULT_WIDTH 72 +#endif + +/* FILE *, for test logging. */ +#ifndef GREATEST_STDOUT +#define GREATEST_STDOUT stdout +#endif + +/* Remove GREATEST_ prefix from most commonly used symbols? */ +#ifndef GREATEST_USE_ABBREVS +#define GREATEST_USE_ABBREVS 1 +#endif + +/* Set to 0 to disable all use of setjmp/longjmp. */ +#ifndef GREATEST_USE_LONGJMP +#define GREATEST_USE_LONGJMP 0 +#endif + +/* Make it possible to replace fprintf with another + * function with the same interface. */ +#ifndef GREATEST_FPRINTF +#define GREATEST_FPRINTF fprintf +#endif + +#if GREATEST_USE_LONGJMP +#include +#endif + +/* Set to 0 to disable all use of time.h / clock(). */ +#ifndef GREATEST_USE_TIME +#define GREATEST_USE_TIME 1 +#endif + +#if GREATEST_USE_TIME +#include +#endif + +/* Floating point type, for ASSERT_IN_RANGE. */ +#ifndef GREATEST_FLOAT +#define GREATEST_FLOAT double +#define GREATEST_FLOAT_FMT "%g" +#endif + +/* Size of buffer for test name + optional '_' separator and suffix */ +#ifndef GREATEST_TESTNAME_BUF_SIZE +#define GREATEST_TESTNAME_BUF_SIZE 128 +#endif + +/********* + * Types * + *********/ + +/* Info for the current running suite. */ +typedef struct greatest_suite_info { + unsigned int tests_run; + unsigned int passed; + unsigned int failed; + unsigned int skipped; + +#if GREATEST_USE_TIME + /* timers, pre/post running suite and individual tests */ + clock_t pre_suite; + clock_t post_suite; + clock_t pre_test; + clock_t post_test; +#endif +} greatest_suite_info; + +/* Type for a suite function. */ +typedef void greatest_suite_cb(void); + +/* Types for setup/teardown callbacks. If non-NULL, these will be run + * and passed the pointer to their additional data. */ +typedef void greatest_setup_cb(void *udata); +typedef void greatest_teardown_cb(void *udata); + +/* Type for an equality comparison between two pointers of the same type. + * Should return non-0 if equal, otherwise 0. + * UDATA is a closure value, passed through from ASSERT_EQUAL_T[m]. */ +typedef int greatest_equal_cb(const void *expd, const void *got, void *udata); + +/* Type for a callback that prints a value pointed to by T. + * Return value has the same meaning as printf's. + * UDATA is a closure value, passed through from ASSERT_EQUAL_T[m]. */ +typedef int greatest_printf_cb(const void *t, void *udata); + +/* Callbacks for an arbitrary type; needed for type-specific + * comparisons via GREATEST_ASSERT_EQUAL_T[m].*/ +typedef struct greatest_type_info { + greatest_equal_cb *equal; + greatest_printf_cb *print; +} greatest_type_info; + +typedef struct greatest_memory_cmp_env { + const unsigned char *exp; + const unsigned char *got; + size_t size; +} greatest_memory_cmp_env; + +/* Callbacks for string and raw memory types. */ +extern greatest_type_info greatest_type_info_string; +extern greatest_type_info greatest_type_info_memory; + +typedef enum { + GREATEST_FLAG_FIRST_FAIL = 0x01, + GREATEST_FLAG_LIST_ONLY = 0x02, + GREATEST_FLAG_ABORT_ON_FAIL = 0x04 +} greatest_flag_t; + +/* Internal state for a PRNG, used to shuffle test order. */ +struct greatest_prng { + unsigned char random_order; /* use random ordering? */ + unsigned char initialized; /* is random ordering initialized? */ + unsigned char pad_0[6]; + unsigned long state; /* PRNG state */ + unsigned long count; /* how many tests, this pass */ + unsigned long count_ceil; /* total number of tests */ + unsigned long count_run; /* total tests run */ + unsigned long a; /* LCG multiplier */ + unsigned long c; /* LCG increment */ + unsigned long m; /* LCG modulus, based on count_ceil */ +}; + +/* Struct containing all test runner state. */ +typedef struct greatest_run_info { + unsigned char flags; + unsigned char verbosity; + unsigned char running_test; /* guard for nested RUN_TEST calls */ + unsigned char exact_name_match; + + unsigned int tests_run; /* total test count */ + + /* currently running test suite */ + greatest_suite_info suite; + + /* overall pass/fail/skip counts */ + unsigned int passed; + unsigned int failed; + unsigned int skipped; + unsigned int assertions; + + /* info to print about the most recent failure */ + unsigned int fail_line; + unsigned int pad_1; + const char *fail_file; + const char *msg; + + /* current setup/teardown hooks and userdata */ + greatest_setup_cb *setup; + void *setup_udata; + greatest_teardown_cb *teardown; + void *teardown_udata; + + /* formatting info for ".....s...F"-style output */ + unsigned int col; + unsigned int width; + + /* only run a specific suite or test */ + const char *suite_filter; + const char *test_filter; + const char *test_exclude; + const char *name_suffix; /* print suffix with test name */ + char name_buf[GREATEST_TESTNAME_BUF_SIZE]; + + struct greatest_prng prng[2]; /* 0: suites, 1: tests */ + +#if GREATEST_USE_TIME + /* overall timers */ + clock_t begin; + clock_t end; +#endif + +#if GREATEST_USE_LONGJMP + int pad_jmp_buf; + unsigned char pad_2[4]; + jmp_buf jump_dest; +#endif +} greatest_run_info; + +struct greatest_report_t { + /* overall pass/fail/skip counts */ + unsigned int passed; + unsigned int failed; + unsigned int skipped; + unsigned int assertions; +}; + +/* Global var for the current testing context. + * Initialized by GREATEST_MAIN_DEFS(). */ +extern greatest_run_info greatest_info; + +/* Type for ASSERT_ENUM_EQ's ENUM_STR argument. */ +typedef const char *greatest_enum_str_fun(int value); + +/********************** + * Exported functions * + **********************/ + +/* These are used internally by greatest macros. */ +int greatest_test_pre(const char *name); +void greatest_test_post(int res); +int greatest_do_assert_equal_t(const void *expd, const void *got, + greatest_type_info *type_info, void *udata); +void greatest_prng_init_first_pass(int id); +int greatest_prng_init_second_pass(int id, unsigned long seed); +void greatest_prng_step(int id); + +/* These are part of the public greatest API. */ +void GREATEST_SET_SETUP_CB(greatest_setup_cb *cb, void *udata); +void GREATEST_SET_TEARDOWN_CB(greatest_teardown_cb *cb, void *udata); +void GREATEST_INIT(void); +void GREATEST_PRINT_REPORT(void); +int greatest_all_passed(void); +void greatest_set_suite_filter(const char *filter); +void greatest_set_test_filter(const char *filter); +void greatest_set_test_exclude(const char *filter); +void greatest_set_exact_name_match(void); +void greatest_stop_at_first_fail(void); +void greatest_abort_on_fail(void); +void greatest_list_only(void); +void greatest_get_report(struct greatest_report_t *report); +unsigned int greatest_get_verbosity(void); +void greatest_set_verbosity(unsigned int verbosity); +void greatest_set_flag(greatest_flag_t flag); +void greatest_set_test_suffix(const char *suffix); + +/******************** + * Language Support * + ********************/ + +/* If __VA_ARGS__ (C99) is supported, allow parametric testing + * without needing to manually manage the argument struct. */ +#if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 19901L) || \ + (defined(_MSC_VER) && _MSC_VER >= 1800) +#define GREATEST_VA_ARGS +#endif + +/********** + * Macros * + **********/ + +/* Define a suite. (The duplication is intentional -- it eliminates + * a warning from -Wmissing-declarations.) */ +#define GREATEST_SUITE(NAME) \ + void NAME(void); \ + void NAME(void) + +/* Declare a suite, provided by another compilation unit. */ +#define GREATEST_SUITE_EXTERN(NAME) void NAME(void) + +/* Start defining a test function. + * The arguments are not included, to allow parametric testing. */ +#define GREATEST_TEST static enum greatest_test_res + +/* PASS/FAIL/SKIP result from a test. Used internally. */ +typedef enum greatest_test_res { + GREATEST_TEST_RES_PASS = 0, + GREATEST_TEST_RES_FAIL = -1, + GREATEST_TEST_RES_SKIP = 1 +} greatest_test_res; + +/* Run a suite. */ +#define GREATEST_RUN_SUITE(S_NAME) greatest_run_suite(S_NAME, #S_NAME) + +/* Run a test in the current suite. */ +#define GREATEST_RUN_TEST(TEST) \ + do { \ + if (greatest_test_pre(#TEST) == 1) { \ + enum greatest_test_res res = GREATEST_SAVE_CONTEXT(); \ + if (res == GREATEST_TEST_RES_PASS) { \ + res = TEST(); \ + } \ + greatest_test_post(res); \ + } \ + } while (0) + +/* Ignore a test, don't warn about it being unused. */ +#define GREATEST_IGNORE_TEST(TEST) (void)TEST + +/* Run a test in the current suite with one void * argument, + * which can be a pointer to a struct with multiple arguments. */ +#define GREATEST_RUN_TEST1(TEST, ENV) \ + do { \ + if (greatest_test_pre(#TEST) == 1) { \ + enum greatest_test_res res = GREATEST_SAVE_CONTEXT(); \ + if (res == GREATEST_TEST_RES_PASS) { \ + res = TEST(ENV); \ + } \ + greatest_test_post(res); \ + } \ + } while (0) + +#ifdef GREATEST_VA_ARGS +#define GREATEST_RUN_TESTp(TEST, ...) \ + do { \ + if (greatest_test_pre(#TEST) == 1) { \ + enum greatest_test_res res = GREATEST_SAVE_CONTEXT(); \ + if (res == GREATEST_TEST_RES_PASS) { \ + res = TEST(__VA_ARGS__); \ + } \ + greatest_test_post(res); \ + } \ + } while (0) +#endif + +/* Check if the test runner is in verbose mode. */ +#define GREATEST_IS_VERBOSE() ((greatest_info.verbosity) > 0) +#define GREATEST_LIST_ONLY() (greatest_info.flags & GREATEST_FLAG_LIST_ONLY) +#define GREATEST_FIRST_FAIL() (greatest_info.flags & GREATEST_FLAG_FIRST_FAIL) +#define GREATEST_ABORT_ON_FAIL() \ + (greatest_info.flags & GREATEST_FLAG_ABORT_ON_FAIL) +#define GREATEST_FAILURE_ABORT() \ + (GREATEST_FIRST_FAIL() && \ + (greatest_info.suite.failed > 0 || greatest_info.failed > 0)) + +/* Message-less forms of tests defined below. */ +#define GREATEST_PASS() GREATEST_PASSm(NULL) +#define GREATEST_FAIL() GREATEST_FAILm(NULL) +#define GREATEST_SKIP() GREATEST_SKIPm(NULL) +#define GREATEST_ASSERT(COND) GREATEST_ASSERTm(#COND, COND) +#define GREATEST_ASSERT_OR_LONGJMP(COND) \ + GREATEST_ASSERT_OR_LONGJMPm(#COND, COND) +#define GREATEST_ASSERT_FALSE(COND) GREATEST_ASSERT_FALSEm(#COND, COND) +#define GREATEST_ASSERT_EQ(EXP, GOT) \ + GREATEST_ASSERT_EQm(#EXP " != " #GOT, EXP, GOT) +#define GREATEST_ASSERT_NEQ(EXP, GOT) \ + GREATEST_ASSERT_NEQm(#EXP " == " #GOT, EXP, GOT) +#define GREATEST_ASSERT_GT(EXP, GOT) \ + GREATEST_ASSERT_GTm(#EXP " <= " #GOT, EXP, GOT) +#define GREATEST_ASSERT_GTE(EXP, GOT) \ + GREATEST_ASSERT_GTEm(#EXP " < " #GOT, EXP, GOT) +#define GREATEST_ASSERT_LT(EXP, GOT) \ + GREATEST_ASSERT_LTm(#EXP " >= " #GOT, EXP, GOT) +#define GREATEST_ASSERT_LTE(EXP, GOT) \ + GREATEST_ASSERT_LTEm(#EXP " > " #GOT, EXP, GOT) +#define GREATEST_ASSERT_EQ_FMT(EXP, GOT, FMT) \ + GREATEST_ASSERT_EQ_FMTm(#EXP " != " #GOT, EXP, GOT, FMT) +#define GREATEST_ASSERT_IN_RANGE(EXP, GOT, TOL) \ + GREATEST_ASSERT_IN_RANGEm(#EXP " != " #GOT " +/- " #TOL, EXP, GOT, TOL) +#define GREATEST_ASSERT_EQUAL_T(EXP, GOT, TYPE_INFO, UDATA) \ + GREATEST_ASSERT_EQUAL_Tm(#EXP " != " #GOT, EXP, GOT, TYPE_INFO, UDATA) +#define GREATEST_ASSERT_STR_EQ(EXP, GOT) \ + GREATEST_ASSERT_STR_EQm(#EXP " != " #GOT, EXP, GOT) +#define GREATEST_ASSERT_STRN_EQ(EXP, GOT, SIZE) \ + GREATEST_ASSERT_STRN_EQm(#EXP " != " #GOT, EXP, GOT, SIZE) +#define GREATEST_ASSERT_MEM_EQ(EXP, GOT, SIZE) \ + GREATEST_ASSERT_MEM_EQm(#EXP " != " #GOT, EXP, GOT, SIZE) +#define GREATEST_ASSERT_ENUM_EQ(EXP, GOT, ENUM_STR) \ + GREATEST_ASSERT_ENUM_EQm(#EXP " != " #GOT, EXP, GOT, ENUM_STR) + +/* The following forms take an additional message argument first, + * to be displayed by the test runner. */ + +/* Fail if a condition is not true, with message. */ +#define GREATEST_ASSERTm(MSG, COND) \ + do { \ + greatest_info.assertions++; \ + if (!(COND)) { \ + GREATEST_FAILm(MSG); \ + } \ + } while (0) + +/* Fail if a condition is not true, longjmping out of test. */ +#define GREATEST_ASSERT_OR_LONGJMPm(MSG, COND) \ + do { \ + greatest_info.assertions++; \ + if (!(COND)) { \ + GREATEST_FAIL_WITH_LONGJMPm(MSG); \ + } \ + } while (0) + +/* Fail if a condition is not false, with message. */ +#define GREATEST_ASSERT_FALSEm(MSG, COND) \ + do { \ + greatest_info.assertions++; \ + if ((COND)) { \ + GREATEST_FAILm(MSG); \ + } \ + } while (0) + +/* Internal macro for relational assertions */ +#define GREATEST__REL(REL, MSG, EXP, GOT) \ + do { \ + greatest_info.assertions++; \ + if (!((EXP)REL(GOT))) { \ + GREATEST_FAILm(MSG); \ + } \ + } while (0) + +/* Fail if EXP is not ==, !=, >, <, >=, or <= to GOT. */ +#define GREATEST_ASSERT_EQm(MSG, E, G) GREATEST__REL(==, MSG, E, G) +#define GREATEST_ASSERT_NEQm(MSG, E, G) GREATEST__REL(!=, MSG, E, G) +#define GREATEST_ASSERT_GTm(MSG, E, G) GREATEST__REL(>, MSG, E, G) +#define GREATEST_ASSERT_GTEm(MSG, E, G) GREATEST__REL(>=, MSG, E, G) +#define GREATEST_ASSERT_LTm(MSG, E, G) GREATEST__REL(<, MSG, E, G) +#define GREATEST_ASSERT_LTEm(MSG, E, G) GREATEST__REL(<=, MSG, E, G) + +/* Fail if EXP != GOT (equality comparison by ==). + * Warning: FMT, EXP, and GOT will be evaluated more + * than once on failure. */ +#define GREATEST_ASSERT_EQ_FMTm(MSG, EXP, GOT, FMT) \ + do { \ + greatest_info.assertions++; \ + if ((EXP) != (GOT)) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\nExpected: "); \ + GREATEST_FPRINTF(GREATEST_STDOUT, FMT, EXP); \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\n Got: "); \ + GREATEST_FPRINTF(GREATEST_STDOUT, FMT, GOT); \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\n"); \ + GREATEST_FAILm(MSG); \ + } \ + } while (0) + +/* Fail if EXP is not equal to GOT, printing enum IDs. */ +#define GREATEST_ASSERT_ENUM_EQm(MSG, EXP, GOT, ENUM_STR) \ + do { \ + int greatest_EXP = (int)(EXP); \ + int greatest_GOT = (int)(GOT); \ + greatest_enum_str_fun *greatest_ENUM_STR = ENUM_STR; \ + if (greatest_EXP != greatest_GOT) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\nExpected: %s", \ + greatest_ENUM_STR(greatest_EXP)); \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\n Got: %s\n", \ + greatest_ENUM_STR(greatest_GOT)); \ + GREATEST_FAILm(MSG); \ + } \ + } while (0) + +/* Fail if GOT not in range of EXP +|- TOL. */ +#define GREATEST_ASSERT_IN_RANGEm(MSG, EXP, GOT, TOL) \ + do { \ + GREATEST_FLOAT greatest_EXP = (EXP); \ + GREATEST_FLOAT greatest_GOT = (GOT); \ + GREATEST_FLOAT greatest_TOL = (TOL); \ + greatest_info.assertions++; \ + if ((greatest_EXP > greatest_GOT && \ + greatest_EXP - greatest_GOT > greatest_TOL) || \ + (greatest_EXP < greatest_GOT && \ + greatest_GOT - greatest_EXP > greatest_TOL)) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, \ + "\nExpected: " GREATEST_FLOAT_FMT \ + " +/- " GREATEST_FLOAT_FMT \ + "\n Got: " GREATEST_FLOAT_FMT "\n", \ + greatest_EXP, greatest_TOL, greatest_GOT); \ + GREATEST_FAILm(MSG); \ + } \ + } while (0) + +/* Fail if EXP is not equal to GOT, according to strcmp. */ +#define GREATEST_ASSERT_STR_EQm(MSG, EXP, GOT) \ + do { \ + GREATEST_ASSERT_EQUAL_Tm(MSG, EXP, GOT, &greatest_type_info_string, NULL); \ + } while (0) + +/* Fail if EXP is not equal to GOT, according to strncmp. */ +#define GREATEST_ASSERT_STRN_EQm(MSG, EXP, GOT, SIZE) \ + do { \ + size_t size = SIZE; \ + GREATEST_ASSERT_EQUAL_Tm(MSG, EXP, GOT, &greatest_type_info_string, \ + &size); \ + } while (0) + +/* Fail if EXP is not equal to GOT, according to memcmp. */ +#define GREATEST_ASSERT_MEM_EQm(MSG, EXP, GOT, SIZE) \ + do { \ + greatest_memory_cmp_env env; \ + env.exp = (const unsigned char *)EXP; \ + env.got = (const unsigned char *)GOT; \ + env.size = SIZE; \ + GREATEST_ASSERT_EQUAL_Tm(MSG, env.exp, env.got, \ + &greatest_type_info_memory, &env); \ + } while (0) + +/* Fail if EXP is not equal to GOT, according to a comparison + * callback in TYPE_INFO. If they are not equal, optionally use a + * print callback in TYPE_INFO to print them. */ +#define GREATEST_ASSERT_EQUAL_Tm(MSG, EXP, GOT, TYPE_INFO, UDATA) \ + do { \ + greatest_type_info *type_info = (TYPE_INFO); \ + greatest_info.assertions++; \ + if (!greatest_do_assert_equal_t(EXP, GOT, type_info, UDATA)) { \ + if (type_info == NULL || type_info->equal == NULL) { \ + GREATEST_FAILm("type_info->equal callback missing!"); \ + } else { \ + GREATEST_FAILm(MSG); \ + } \ + } \ + } while (0) + +/* Pass. */ +#define GREATEST_PASSm(MSG) \ + do { \ + greatest_info.msg = MSG; \ + return GREATEST_TEST_RES_PASS; \ + } while (0) + +/* Fail. */ +#define GREATEST_FAILm(MSG) \ + do { \ + greatest_info.fail_file = __FILE__; \ + greatest_info.fail_line = __LINE__; \ + greatest_info.msg = MSG; \ + if (GREATEST_ABORT_ON_FAIL()) { \ + abort(); \ + } \ + return GREATEST_TEST_RES_FAIL; \ + } while (0) + +/* Optional GREATEST_FAILm variant that longjmps. */ +#if GREATEST_USE_LONGJMP +#define GREATEST_FAIL_WITH_LONGJMP() GREATEST_FAIL_WITH_LONGJMPm(NULL) +#define GREATEST_FAIL_WITH_LONGJMPm(MSG) \ + do { \ + greatest_info.fail_file = __FILE__; \ + greatest_info.fail_line = __LINE__; \ + greatest_info.msg = MSG; \ + longjmp(greatest_info.jump_dest, GREATEST_TEST_RES_FAIL); \ + } while (0) +#endif + +/* Skip the current test. */ +#define GREATEST_SKIPm(MSG) \ + do { \ + greatest_info.msg = MSG; \ + return GREATEST_TEST_RES_SKIP; \ + } while (0) + +/* Check the result of a subfunction using ASSERT, etc. */ +#define GREATEST_CHECK_CALL(RES) \ + do { \ + enum greatest_test_res greatest_RES = RES; \ + if (greatest_RES != GREATEST_TEST_RES_PASS) { \ + return greatest_RES; \ + } \ + } while (0) + +#if GREATEST_USE_TIME +#define GREATEST_SET_TIME(NAME) \ + NAME = clock(); \ + if (NAME == (clock_t)-1) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "clock error: %s\n", #NAME); \ + exit(EXIT_FAILURE); \ + } + +#define GREATEST_CLOCK_DIFF(C1, C2) \ + GREATEST_FPRINTF(GREATEST_STDOUT, " (%lu ticks, %.3f sec)", \ + (long unsigned int)(C2) - (long unsigned int)(C1), \ + (double)((C2) - (C1)) / (1.0 * (double)CLOCKS_PER_SEC)) +#else +#define GREATEST_SET_TIME(UNUSED) +#define GREATEST_CLOCK_DIFF(UNUSED1, UNUSED2) +#endif + +#if GREATEST_USE_LONGJMP +#define GREATEST_SAVE_CONTEXT() \ + /* setjmp returns 0 (GREATEST_TEST_RES_PASS) on first call * \ + * so the test runs, then RES_FAIL from FAIL_WITH_LONGJMP. */ \ + ((enum greatest_test_res)(setjmp(greatest_info.jump_dest))) +#else +#define GREATEST_SAVE_CONTEXT() \ + /*a no-op, since setjmp/longjmp aren't being used */ \ + GREATEST_TEST_RES_PASS +#endif + +/* Run every suite / test function run within BODY in pseudo-random + * order, seeded by SEED. (The top 3 bits of the seed are ignored.) + * + * This should be called like: + * GREATEST_SHUFFLE_TESTS(seed, { + * GREATEST_RUN_TEST(some_test); + * GREATEST_RUN_TEST(some_other_test); + * GREATEST_RUN_TEST(yet_another_test); + * }); + * + * Note that the body of the second argument will be evaluated + * multiple times. */ +#define GREATEST_SHUFFLE_SUITES(SD, BODY) GREATEST_SHUFFLE(0, SD, BODY) +#define GREATEST_SHUFFLE_TESTS(SD, BODY) GREATEST_SHUFFLE(1, SD, BODY) +#define GREATEST_SHUFFLE(ID, SD, BODY) \ + do { \ + struct greatest_prng *prng = &greatest_info.prng[ID]; \ + greatest_prng_init_first_pass(ID); \ + do { \ + prng->count = 0; \ + if (prng->initialized) { \ + greatest_prng_step(ID); \ + } \ + BODY; \ + if (!prng->initialized) { \ + if (!greatest_prng_init_second_pass(ID, SD)) { \ + break; \ + } \ + } else if (prng->count_run == prng->count_ceil) { \ + break; \ + } \ + } while (!GREATEST_FAILURE_ABORT()); \ + prng->count_run = prng->random_order = prng->initialized = 0; \ + } while (0) + +/* Include several function definitions in the main test file. */ +#define GREATEST_MAIN_DEFS() \ + \ + /* Is FILTER a subset of NAME? */ \ + static int greatest_name_match(const char *name, const char *filter, \ + int res_if_none) { \ + size_t offset = 0; \ + size_t filter_len = filter ? strlen(filter) : 0; \ + if (filter_len == 0) { \ + return res_if_none; \ + } /* no filter */ \ + if (greatest_info.exact_name_match && strlen(name) != filter_len) { \ + return 0; /* ignore substring matches */ \ + } \ + while (name[offset] != '\0') { \ + if (name[offset] == filter[0]) { \ + if (0 == strncmp(&name[offset], filter, filter_len)) { \ + return 1; \ + } \ + } \ + offset++; \ + } \ + \ + return 0; \ + } \ + \ + static void greatest_buffer_test_name(const char *name) { \ + struct greatest_run_info *g = &greatest_info; \ + size_t len = strlen(name), size = sizeof(g->name_buf); \ + memset(g->name_buf, 0x00, size); \ + (void)strncat(g->name_buf, name, size - 1); \ + if (g->name_suffix && (len + 1 < size)) { \ + g->name_buf[len] = '_'; \ + strncat(&g->name_buf[len + 1], g->name_suffix, size - (len + 2)); \ + } \ + } \ + \ + /* Before running a test, check the name filtering and \ + * test shuffling state, if applicable, and then call setup hooks. */ \ + int greatest_test_pre(const char *name) { \ + struct greatest_run_info *g = &greatest_info; \ + int match; \ + greatest_buffer_test_name(name); \ + match = greatest_name_match(g->name_buf, g->test_filter, 1) && \ + !greatest_name_match(g->name_buf, g->test_exclude, 0); \ + if (GREATEST_LIST_ONLY()) { /* just listing test names */ \ + if (match) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, " %s\n", g->name_buf); \ + } \ + goto clear; \ + } \ + if (match && (!GREATEST_FIRST_FAIL() || g->suite.failed == 0)) { \ + struct greatest_prng *p = &g->prng[1]; \ + if (p->random_order) { \ + p->count++; \ + if (!p->initialized || ((p->count - 1) != p->state)) { \ + goto clear; /* don't run this test yet */ \ + } \ + } \ + if (g->running_test) { \ + fprintf(stderr, "Error: Test run inside another test.\n"); \ + return 0; \ + } \ + GREATEST_SET_TIME(g->suite.pre_test); \ + if (g->setup) { \ + g->setup(g->setup_udata); \ + } \ + p->count_run++; \ + g->running_test = 1; \ + return 1; /* test should be run */ \ + } else { \ + goto clear; /* skipped */ \ + } \ + clear: \ + g->name_suffix = NULL; \ + return 0; \ + } \ + \ + static void greatest_do_pass(void) { \ + struct greatest_run_info *g = &greatest_info; \ + if (GREATEST_IS_VERBOSE()) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "PASS %s: %s", g->name_buf, \ + g->msg ? g->msg : ""); \ + } else { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "."); \ + } \ + g->suite.passed++; \ + } \ + \ + static void greatest_do_fail(void) { \ + struct greatest_run_info *g = &greatest_info; \ + if (GREATEST_IS_VERBOSE()) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "FAIL %s: %s (%s:%u)", g->name_buf, \ + g->msg ? g->msg : "", g->fail_file, g->fail_line); \ + } else { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "F"); \ + g->col++; /* add linebreak if in line of '.'s */ \ + if (g->col != 0) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\n"); \ + g->col = 0; \ + } \ + GREATEST_FPRINTF(GREATEST_STDOUT, "FAIL %s: %s (%s:%u)\n", g->name_buf, \ + g->msg ? g->msg : "", g->fail_file, g->fail_line); \ + } \ + g->suite.failed++; \ + } \ + \ + static void greatest_do_skip(void) { \ + struct greatest_run_info *g = &greatest_info; \ + if (GREATEST_IS_VERBOSE()) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "SKIP %s: %s", g->name_buf, \ + g->msg ? g->msg : ""); \ + } else { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "s"); \ + } \ + g->suite.skipped++; \ + } \ + \ + void greatest_test_post(int res) { \ + GREATEST_SET_TIME(greatest_info.suite.post_test); \ + if (greatest_info.teardown) { \ + void *udata = greatest_info.teardown_udata; \ + greatest_info.teardown(udata); \ + } \ + \ + greatest_info.running_test = 0; \ + if (res <= GREATEST_TEST_RES_FAIL) { \ + greatest_do_fail(); \ + } else if (res >= GREATEST_TEST_RES_SKIP) { \ + greatest_do_skip(); \ + } else if (res == GREATEST_TEST_RES_PASS) { \ + greatest_do_pass(); \ + } \ + greatest_info.name_suffix = NULL; \ + greatest_info.suite.tests_run++; \ + greatest_info.col++; \ + if (GREATEST_IS_VERBOSE()) { \ + GREATEST_CLOCK_DIFF(greatest_info.suite.pre_test, \ + greatest_info.suite.post_test); \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\n"); \ + } else if (greatest_info.col % greatest_info.width == 0) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\n"); \ + greatest_info.col = 0; \ + } \ + fflush(GREATEST_STDOUT); \ + } \ + \ + static void report_suite(void) { \ + if (greatest_info.suite.tests_run > 0) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, \ + "\n%u test%s - %u passed, %u failed, %u skipped", \ + greatest_info.suite.tests_run, \ + greatest_info.suite.tests_run == 1 ? "" : "s", \ + greatest_info.suite.passed, greatest_info.suite.failed, \ + greatest_info.suite.skipped); \ + GREATEST_CLOCK_DIFF(greatest_info.suite.pre_suite, \ + greatest_info.suite.post_suite); \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\n"); \ + } \ + } \ + \ + static void update_counts_and_reset_suite(void) { \ + greatest_info.setup = NULL; \ + greatest_info.setup_udata = NULL; \ + greatest_info.teardown = NULL; \ + greatest_info.teardown_udata = NULL; \ + greatest_info.passed += greatest_info.suite.passed; \ + greatest_info.failed += greatest_info.suite.failed; \ + greatest_info.skipped += greatest_info.suite.skipped; \ + greatest_info.tests_run += greatest_info.suite.tests_run; \ + memset(&greatest_info.suite, 0, sizeof(greatest_info.suite)); \ + greatest_info.col = 0; \ + } \ + \ + static int greatest_suite_pre(const char *suite_name) { \ + struct greatest_prng *p = &greatest_info.prng[0]; \ + if (!greatest_name_match(suite_name, greatest_info.suite_filter, 1) || \ + (GREATEST_FAILURE_ABORT())) { \ + return 0; \ + } \ + if (p->random_order) { \ + p->count++; \ + if (!p->initialized || ((p->count - 1) != p->state)) { \ + return 0; /* don't run this suite yet */ \ + } \ + } \ + p->count_run++; \ + update_counts_and_reset_suite(); \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\n* Suite %s:\n", suite_name); \ + GREATEST_SET_TIME(greatest_info.suite.pre_suite); \ + return 1; \ + } \ + \ + static void greatest_suite_post(void) { \ + GREATEST_SET_TIME(greatest_info.suite.post_suite); \ + report_suite(); \ + } \ + \ + static void greatest_run_suite(greatest_suite_cb *suite_cb, \ + const char *suite_name) { \ + if (greatest_suite_pre(suite_name)) { \ + suite_cb(); \ + greatest_suite_post(); \ + } \ + } \ + \ + int greatest_do_assert_equal_t(const void *expd, const void *got, \ + greatest_type_info *type_info, void *udata) { \ + int eq = 0; \ + if (type_info == NULL || type_info->equal == NULL) { \ + return 0; \ + } \ + eq = type_info->equal(expd, got, udata); \ + if (!eq) { \ + if (type_info->print != NULL) { \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\nExpected: "); \ + (void)type_info->print(expd, udata); \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\n Got: "); \ + (void)type_info->print(got, udata); \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\n"); \ + } \ + } \ + return eq; \ + } \ + \ + static void greatest_usage(const char *name) { \ + GREATEST_FPRINTF( \ + GREATEST_STDOUT, \ + "Usage: %s [-hlfavex] [-s SUITE] [-t TEST] [-x EXCLUDE]\n" \ + " -h, --help print this Help\n" \ + " -l List suites and tests, then exit (dry run)\n" \ + " -f Stop runner after first failure\n" \ + " -a Abort on first failure (implies -f)\n" \ + " -v Verbose output\n" \ + " -s SUITE only run suites containing substring SUITE\n" \ + " -t TEST only run tests containing substring TEST\n" \ + " -e only run exact name match for -s or -t\n" \ + " -x EXCLUDE exclude tests containing substring EXCLUDE\n", \ + name); \ + } \ + \ + static void greatest_parse_options(int argc, char **argv) { \ + int i = 0; \ + for (i = 1; i < argc; i++) { \ + if (argv[i][0] == '-') { \ + char f = argv[i][1]; \ + if ((f == 's' || f == 't' || f == 'x') && argc <= i + 1) { \ + greatest_usage(argv[0]); \ + exit(EXIT_FAILURE); \ + } \ + switch (f) { \ + case 's': /* suite name filter */ \ + greatest_set_suite_filter(argv[i + 1]); \ + i++; \ + break; \ + case 't': /* test name filter */ \ + greatest_set_test_filter(argv[i + 1]); \ + i++; \ + break; \ + case 'x': /* test name exclusion */ \ + greatest_set_test_exclude(argv[i + 1]); \ + i++; \ + break; \ + case 'e': /* exact name match */ \ + greatest_set_exact_name_match(); \ + break; \ + case 'f': /* first fail flag */ \ + greatest_stop_at_first_fail(); \ + break; \ + case 'a': /* abort() on fail flag */ \ + greatest_abort_on_fail(); \ + break; \ + case 'l': /* list only (dry run) */ \ + greatest_list_only(); \ + break; \ + case 'v': /* first fail flag */ \ + greatest_info.verbosity++; \ + break; \ + case 'h': /* help */ \ + greatest_usage(argv[0]); \ + exit(EXIT_SUCCESS); \ + default: \ + case '-': \ + if (0 == strncmp("--help", argv[i], 6)) { \ + greatest_usage(argv[0]); \ + exit(EXIT_SUCCESS); \ + } else if (0 == strcmp("--", argv[i])) { \ + return; /* ignore following arguments */ \ + } \ + GREATEST_FPRINTF(GREATEST_STDOUT, "Unknown argument '%s'\n", \ + argv[i]); \ + greatest_usage(argv[0]); \ + exit(EXIT_FAILURE); \ + } \ + } \ + } \ + } \ + \ + int greatest_all_passed(void) { return (greatest_info.failed == 0); } \ + \ + void greatest_set_test_filter(const char *filter) { \ + greatest_info.test_filter = filter; \ + } \ + \ + void greatest_set_test_exclude(const char *filter) { \ + greatest_info.test_exclude = filter; \ + } \ + \ + void greatest_set_suite_filter(const char *filter) { \ + greatest_info.suite_filter = filter; \ + } \ + \ + void greatest_set_exact_name_match(void) { \ + greatest_info.exact_name_match = 1; \ + } \ + \ + void greatest_stop_at_first_fail(void) { \ + greatest_set_flag(GREATEST_FLAG_FIRST_FAIL); \ + } \ + \ + void greatest_abort_on_fail(void) { \ + greatest_set_flag(GREATEST_FLAG_ABORT_ON_FAIL); \ + } \ + \ + void greatest_list_only(void) { \ + greatest_set_flag(GREATEST_FLAG_LIST_ONLY); \ + } \ + \ + void greatest_get_report(struct greatest_report_t *report) { \ + if (report) { \ + report->passed = greatest_info.passed; \ + report->failed = greatest_info.failed; \ + report->skipped = greatest_info.skipped; \ + report->assertions = greatest_info.assertions; \ + } \ + } \ + \ + unsigned int greatest_get_verbosity(void) { \ + return greatest_info.verbosity; \ + } \ + \ + void greatest_set_verbosity(unsigned int verbosity) { \ + greatest_info.verbosity = (unsigned char)verbosity; \ + } \ + \ + void greatest_set_flag(greatest_flag_t flag) { \ + greatest_info.flags = (unsigned char)(greatest_info.flags | flag); \ + } \ + \ + void greatest_set_test_suffix(const char *suffix) { \ + greatest_info.name_suffix = suffix; \ + } \ + \ + void GREATEST_SET_SETUP_CB(greatest_setup_cb *cb, void *udata) { \ + greatest_info.setup = cb; \ + greatest_info.setup_udata = udata; \ + } \ + \ + void GREATEST_SET_TEARDOWN_CB(greatest_teardown_cb *cb, void *udata) { \ + greatest_info.teardown = cb; \ + greatest_info.teardown_udata = udata; \ + } \ + \ + static int greatest_string_equal_cb(const void *expd, const void *got, \ + void *udata) { \ + size_t *size = (size_t *)udata; \ + return (size != NULL \ + ? (0 == strncmp((const char *)expd, (const char *)got, *size)) \ + : (0 == strcmp((const char *)expd, (const char *)got))); \ + } \ + \ + static int greatest_string_printf_cb(const void *t, void *udata) { \ + (void)udata; /* note: does not check \0 termination. */ \ + return GREATEST_FPRINTF(GREATEST_STDOUT, "%s", (const char *)t); \ + } \ + \ + greatest_type_info greatest_type_info_string = { \ + greatest_string_equal_cb, \ + greatest_string_printf_cb, \ + }; \ + \ + static int greatest_memory_equal_cb(const void *expd, const void *got, \ + void *udata) { \ + greatest_memory_cmp_env *env = (greatest_memory_cmp_env *)udata; \ + return (0 == memcmp(expd, got, env->size)); \ + } \ + \ + /* Hexdump raw memory, with differences highlighted */ \ + static int greatest_memory_printf_cb(const void *t, void *udata) { \ + greatest_memory_cmp_env *env = (greatest_memory_cmp_env *)udata; \ + const unsigned char *buf = (const unsigned char *)t; \ + unsigned char diff_mark = ' '; \ + FILE *out = GREATEST_STDOUT; \ + size_t i, line_i, line_len = 0; \ + int len = 0; /* format hexdump with differences highlighted */ \ + for (i = 0; i < env->size; i += line_len) { \ + diff_mark = ' '; \ + line_len = env->size - i; \ + if (line_len > 16) { \ + line_len = 16; \ + } \ + for (line_i = i; line_i < i + line_len; line_i++) { \ + if (env->exp[line_i] != env->got[line_i]) \ + diff_mark = 'X'; \ + } \ + len += GREATEST_FPRINTF(out, "\n%04x %c ", (unsigned int)i, diff_mark); \ + for (line_i = i; line_i < i + line_len; line_i++) { \ + int m = env->exp[line_i] == env->got[line_i]; /* match? */ \ + len += GREATEST_FPRINTF(out, "%02x%c", buf[line_i], m ? ' ' : '<'); \ + } \ + for (line_i = 0; line_i < 16 - line_len; line_i++) { \ + len += GREATEST_FPRINTF(out, " "); \ + } \ + GREATEST_FPRINTF(out, " "); \ + for (line_i = i; line_i < i + line_len; line_i++) { \ + unsigned char c = buf[line_i]; \ + len += GREATEST_FPRINTF(out, "%c", isprint(c) ? c : '.'); \ + } \ + } \ + len += GREATEST_FPRINTF(out, "\n"); \ + return len; \ + } \ + \ + void greatest_prng_init_first_pass(int id) { \ + greatest_info.prng[id].random_order = 1; \ + greatest_info.prng[id].count_run = 0; \ + } \ + \ + int greatest_prng_init_second_pass(int id, unsigned long seed) { \ + struct greatest_prng *p = &greatest_info.prng[id]; \ + if (p->count == 0) { \ + return 0; \ + } \ + p->count_ceil = p->count; \ + for (p->m = 1; p->m < p->count; p->m <<= 1) { \ + } \ + p->state = seed & 0x1fffffff; /* only use lower 29 bits */ \ + p->a = 4LU * p->state; /* to avoid overflow when */ \ + p->a = (p->a ? p->a : 4) | 1; /* multiplied by 4 */ \ + p->c = 2147483647; /* and so p->c ((2 ** 31) - 1) is */ \ + p->initialized = 1; /* always relatively prime to p->a. */ \ + fprintf(stderr, "init_second_pass: a %lu, c %lu, state %lu\n", p->a, p->c, \ + p->state); \ + return 1; \ + } \ + \ + /* Step the pseudorandom number generator until its state reaches \ + * another test ID between 0 and the test count. \ + * This use a linear congruential pseudorandom number generator, \ + * with the power-of-two ceiling of the test count as the modulus, the \ + * masked seed as the multiplier, and a prime as the increment. For \ + * each generated value < the test count, run the corresponding test. \ + * This will visit all IDs 0 <= X < mod once before repeating, \ + * with a starting position chosen based on the initial seed. \ + * For details, see: Knuth, The Art of Computer Programming \ + * Volume. 2, section 3.2.1. */ \ + void greatest_prng_step(int id) { \ + struct greatest_prng *p = &greatest_info.prng[id]; \ + do { \ + p->state = ((p->a * p->state) + p->c) & (p->m - 1); \ + } while (p->state >= p->count_ceil); \ + } \ + \ + void GREATEST_INIT(void) { \ + /* Suppress unused function warning if features aren't used */ \ + (void)greatest_run_suite; \ + (void)greatest_parse_options; \ + (void)greatest_prng_step; \ + (void)greatest_prng_init_first_pass; \ + (void)greatest_prng_init_second_pass; \ + (void)greatest_set_test_suffix; \ + \ + memset(&greatest_info, 0, sizeof(greatest_info)); \ + greatest_info.width = GREATEST_DEFAULT_WIDTH; \ + GREATEST_SET_TIME(greatest_info.begin); \ + } \ + \ + /* Report passes, failures, skipped tests, the number of \ + * assertions, and the overall run time. */ \ + void GREATEST_PRINT_REPORT(void) { \ + if (!GREATEST_LIST_ONLY()) { \ + update_counts_and_reset_suite(); \ + GREATEST_SET_TIME(greatest_info.end); \ + GREATEST_FPRINTF(GREATEST_STDOUT, "\nTotal: %u test%s", \ + greatest_info.tests_run, \ + greatest_info.tests_run == 1 ? "" : "s"); \ + GREATEST_CLOCK_DIFF(greatest_info.begin, greatest_info.end); \ + GREATEST_FPRINTF(GREATEST_STDOUT, ", %u assertion%s\n", \ + greatest_info.assertions, \ + greatest_info.assertions == 1 ? "" : "s"); \ + GREATEST_FPRINTF(GREATEST_STDOUT, "Pass: %u, fail: %u, skip: %u.\n", \ + greatest_info.passed, greatest_info.failed, \ + greatest_info.skipped); \ + } \ + } \ + \ + greatest_type_info greatest_type_info_memory = { \ + greatest_memory_equal_cb, \ + greatest_memory_printf_cb, \ + }; \ + \ + greatest_run_info greatest_info + +/* Handle command-line arguments, etc. */ +#define GREATEST_MAIN_BEGIN() \ + do { \ + GREATEST_INIT(); \ + greatest_parse_options(argc, argv); \ + } while (0) + +/* Report results, exit with exit status based on results. */ +#define GREATEST_MAIN_END() \ + do { \ + GREATEST_PRINT_REPORT(); \ + return (greatest_all_passed() ? EXIT_SUCCESS : EXIT_FAILURE); \ + } while (0) + +/* Make abbreviations without the GREATEST_ prefix for the + * most commonly used symbols. */ +#if GREATEST_USE_ABBREVS +#define TEST GREATEST_TEST +#define SUITE GREATEST_SUITE +#define SUITE_EXTERN GREATEST_SUITE_EXTERN +#define RUN_TEST GREATEST_RUN_TEST +#define RUN_TEST1 GREATEST_RUN_TEST1 +#define RUN_SUITE GREATEST_RUN_SUITE +#define IGNORE_TEST GREATEST_IGNORE_TEST +#define ASSERT GREATEST_ASSERT +#define ASSERTm GREATEST_ASSERTm +#define ASSERT_FALSE GREATEST_ASSERT_FALSE +#define ASSERT_EQ GREATEST_ASSERT_EQ +#define ASSERT_NEQ GREATEST_ASSERT_NEQ +#define ASSERT_GT GREATEST_ASSERT_GT +#define ASSERT_GTE GREATEST_ASSERT_GTE +#define ASSERT_LT GREATEST_ASSERT_LT +#define ASSERT_LTE GREATEST_ASSERT_LTE +#define ASSERT_EQ_FMT GREATEST_ASSERT_EQ_FMT +#define ASSERT_IN_RANGE GREATEST_ASSERT_IN_RANGE +#define ASSERT_EQUAL_T GREATEST_ASSERT_EQUAL_T +#define ASSERT_STR_EQ GREATEST_ASSERT_STR_EQ +#define ASSERT_STRN_EQ GREATEST_ASSERT_STRN_EQ +#define ASSERT_MEM_EQ GREATEST_ASSERT_MEM_EQ +#define ASSERT_ENUM_EQ GREATEST_ASSERT_ENUM_EQ +#define ASSERT_FALSEm GREATEST_ASSERT_FALSEm +#define ASSERT_EQm GREATEST_ASSERT_EQm +#define ASSERT_NEQm GREATEST_ASSERT_NEQm +#define ASSERT_GTm GREATEST_ASSERT_GTm +#define ASSERT_GTEm GREATEST_ASSERT_GTEm +#define ASSERT_LTm GREATEST_ASSERT_LTm +#define ASSERT_LTEm GREATEST_ASSERT_LTEm +#define ASSERT_EQ_FMTm GREATEST_ASSERT_EQ_FMTm +#define ASSERT_IN_RANGEm GREATEST_ASSERT_IN_RANGEm +#define ASSERT_EQUAL_Tm GREATEST_ASSERT_EQUAL_Tm +#define ASSERT_STR_EQm GREATEST_ASSERT_STR_EQm +#define ASSERT_STRN_EQm GREATEST_ASSERT_STRN_EQm +#define ASSERT_MEM_EQm GREATEST_ASSERT_MEM_EQm +#define ASSERT_ENUM_EQm GREATEST_ASSERT_ENUM_EQm +#define PASS GREATEST_PASS +#define FAIL GREATEST_FAIL +#define SKIP GREATEST_SKIP +#define PASSm GREATEST_PASSm +#define FAILm GREATEST_FAILm +#define SKIPm GREATEST_SKIPm +#define SET_SETUP GREATEST_SET_SETUP_CB +#define SET_TEARDOWN GREATEST_SET_TEARDOWN_CB +#define CHECK_CALL GREATEST_CHECK_CALL +#define SHUFFLE_TESTS GREATEST_SHUFFLE_TESTS +#define SHUFFLE_SUITES GREATEST_SHUFFLE_SUITES + +#ifdef GREATEST_VA_ARGS +#define RUN_TESTp GREATEST_RUN_TESTp +#endif + +#if GREATEST_USE_LONGJMP +#define ASSERT_OR_LONGJMP GREATEST_ASSERT_OR_LONGJMP +#define ASSERT_OR_LONGJMPm GREATEST_ASSERT_OR_LONGJMPm +#define FAIL_WITH_LONGJMP GREATEST_FAIL_WITH_LONGJMP +#define FAIL_WITH_LONGJMPm GREATEST_FAIL_WITH_LONGJMPm +#endif + +#endif /* USE_ABBREVS */ + +#if defined(__cplusplus) && !defined(GREATEST_NO_EXTERN_CPLUSPLUS) +} +#endif + +#endif diff --git a/vendors/irmin/test/libirmin/test.c b/vendors/irmin/test/libirmin/test.c new file mode 100644 index 0000000000000000000000000000000000000000..571c19b0c75f6accaa35d992456317452213e2e4 --- /dev/null +++ b/vendors/irmin/test/libirmin/test.c @@ -0,0 +1,164 @@ +#include "irmin.h" +#include +#include +#include + +#include "greatest.h" + +TEST test_irmin_value_json(void) { + AUTO IrminType *json = irmin_type_json(); + IrminValue *j1 = irmin_value_of_string(json, "{\"a\": 1}", -1); + ASSERT_NEQ(j1, NULL); + irmin_value_free(j1); + + IrminValue *j2 = irmin_value_of_string(json, "{\"a\": 1", -1); + ASSERT_EQ(j2, NULL); + + PASS(); +} + +TEST test_irmin_store(void) { + // Setup config + AUTO IrminConfig *config = irmin_config_git_mem(NULL); + + // Initialize repo and store + AUTO IrminRepo *repo = irmin_repo_new(config); + AUTO Irmin *store = irmin_main(repo); + + // Create new string value + AUTO IrminString *a = irmin_string_new("123", 3); + + // Create path: a/b/c + char *k[] = {"a", "b", "c", NULL}; + AUTO IrminPath *path = irmin_path(repo, k); + + // Create commit info + AUTO IrminInfo *info = irmin_info_new(repo, "test", "set"); + + // Set a/b/c to "123" + ASSERT(irmin_set(store, path, (IrminContents *)a, info)); + ASSERT(irmin_mem(store, path)); + + // Get a/b/c from store + AUTO IrminString *v = (IrminString *)irmin_find(store, path); + ASSERT_NEQ(v, NULL); + + // Get string representation + uint64_t length = irmin_string_length(v); + ASSERT_EQ(strncmp(irmin_string_data(v), irmin_string_data(a), length), 0); + + // Check that tree exists at a/b + AUTO IrminPath *path1 = irmin_path_of_string(repo, "a/b", -1); + ASSERT(irmin_mem_tree(store, path1)); + + // Get tree at a/b + AUTO IrminTree *t = irmin_find_tree(store, path1); + + // Set d to "456" + AUTO IrminPath *path2 = irmin_path_of_string(repo, "d", 1); + AUTO IrminString *b = irmin_string_new("456", -1); + irmin_tree_add(repo, t, path2, (IrminContents *)b, NULL); + ASSERT(irmin_tree_mem(repo, t, path2)); + + // Commit updated tree + info = irmin_realloc(info, irmin_info_new(repo, "test", "tree")); + irmin_set_tree(store, path1, t, info); + + // Ensure the store contains a/b/d + AUTO IrminPath *path3 = irmin_path_of_string(repo, "a/b/d", -1); + ASSERT(irmin_mem(store, path3)); + + // Big string + size_t size = 1024 * 1024 * 64; + char *src = malloc(size); + memset(src, 'a', size); + AUTO IrminContents *big_string = + (IrminContents *)irmin_value_string(src, size); + AUTO IrminInfo *info2 = irmin_info_new(repo, "test", "big_string"); + ASSERT(irmin_set(store, path3, big_string, info2)); + AUTO IrminString *big_string_ = (IrminString *)irmin_find(store, path3); + ASSERT_EQ(irmin_string_length(big_string_), size); + ASSERT_EQ(strncmp(irmin_string_data(big_string_), src, size), 0); + free(src); + + // List + IrminPathArray *paths = irmin_list(store, path1); + ASSERT_EQ(irmin_path_array_length(repo, paths), 2); + + // Fetch + AUTO IrminRepo *repo1 = irmin_repo_new(config); + AUTO Irmin *store1 = irmin_main(repo1); + AUTO IrminRemote *remote = irmin_remote_store(store); + AUTO IrminCommit *c = irmin_fetch(store1, -1, remote); + ASSERT(c); + ASSERT(irmin_mem(store1, path3)); + + // Push + info = irmin_realloc(info, irmin_info_new(repo1, "test", "push")); + ASSERT(irmin_remove(store1, path3, info)); + c = irmin_realloc(c, irmin_push(store1, -1, remote)); + ASSERT(c); + + ASSERT_FALSE(irmin_mem(store1, path3)); + + PASS(); +} + +TEST test_irmin_tree(void) { + // Setup config + AUTO IrminConfig *config = irmin_config_mem(NULL, NULL); + + // Initialize repo and store + AUTO IrminRepo *repo = irmin_repo_new(config); + AUTO Irmin *store = irmin_main(repo); + + AUTO IrminTree *tree = irmin_tree_new(repo); + + AUTO IrminPath *p1 = irmin_path_of_string(repo, "a/b/c", -1); + AUTO IrminContents *v1 = irmin_contents_of_string(repo, "1", -1); + ASSERT(irmin_tree_add(repo, tree, p1, v1, NULL)); + + AUTO IrminPath *ab = irmin_path_parent(repo, p1); + ASSERT(irmin_tree_mem_tree(repo, tree, ab)); + AUTO IrminContents *v2 = irmin_tree_find(repo, tree, p1); + ASSERT_NEQ(v2, NULL); + + AUTO IrminType *ty = irmin_type_contents(repo); + ASSERT(irmin_value_equal(ty, (IrminValue *)v1, (IrminValue *)v2)); + + AUTO IrminPath *empty = irmin_path_empty(repo); + AUTO IrminInfo *info = irmin_info_new(repo, "test", "tree a/b/c"); + ASSERT(irmin_set_tree(store, empty, tree, info)); + ASSERT(irmin_tree_mem(repo, tree, p1)); + + AUTO IrminKindedKey *key = irmin_tree_key(repo, tree); + ASSERT_NEQ(key, NULL); + ASSERT(irmin_kinded_key_is_node(repo, key)); + + AUTO IrminHash *hash = irmin_tree_hash(repo, tree); + ASSERT_NEQ(hash, NULL); + + AUTO IrminTree *tree1 = irmin_tree_of_key(repo, key); + ASSERT_NEQ(tree1, NULL); + + AUTO IrminTree *tree2 = irmin_tree_of_key(repo, key); + ASSERT_NEQ(tree2, NULL); + + AUTO IrminType *ty1 = irmin_type_tree(repo); + ASSERT(irmin_value_equal(ty1, (IrminValue *)tree1, (IrminValue *)tree2)); + + ASSERT_FALSE(irmin_repo_has_error(repo)); + + PASS(); +} + +GREATEST_MAIN_DEFS(); + +int main(int argc, char *argv[]) { + GREATEST_MAIN_BEGIN(); + irmin_log_level("error"); + RUN_TEST(test_irmin_value_json); + RUN_TEST(test_irmin_store); + RUN_TEST(test_irmin_tree); + GREATEST_MAIN_END(); +} diff --git a/vendors/irmin/test/ppx_irmin/dune b/vendors/irmin/test/ppx_irmin/dune new file mode 100644 index 0000000000000000000000000000000000000000..c549f9af30ab49874fe8f7d050d40b67bf4175e4 --- /dev/null +++ b/vendors/irmin/test/ppx_irmin/dune @@ -0,0 +1,55 @@ +;; The PPX-dependent executable under test + +(executable + (name test_logs) + (modules test_logs) + (preprocess + (pps ppx_irmin.internal)) + (libraries fmt)) + +;; Run the PPX on the `.ml` file + +(rule + (targets pp.ml) + (action + (write-file %{targets} "let () = Ppxlib.Driver.standalone ()"))) + +(executable + (name pp) + (modules pp) + (libraries ppx_irmin.internal ppxlib)) + +(rule + (targets test_logs-processed.actual) + (deps + (:pp pp.exe) + (:input test_logs.ml)) + (action + (run ./%{pp} -deriving-keep-w32 both --impl %{input} -o %{targets}))) + +;; Compare the post-processed output to the .expected file + +(rule + (alias runtest) + (package ppx_irmin) + (action + (diff test_logs-processed.expected test_logs-processed.actual))) + +;; Ensure that the post-processed executable runs correctly + +(rule + (alias runtest) + (targets test_logs-output.actual) + (package ppx_irmin) + (action + (with-outputs-to + %{targets} + (run ./test_logs.exe)))) + +;; Compare the output logs of the executable run to the .expected file + +(rule + (alias runtest) + (package ppx_irmin) + (action + (diff test_logs-output.expected test_logs-output.actual))) diff --git a/vendors/irmin/test/ppx_irmin/test_logs-output.expected b/vendors/irmin/test/ppx_irmin/test_logs-output.expected new file mode 100644 index 0000000000000000000000000000000000000000..5430cdab83f8ce50d34af0599cbf164e636ca65c --- /dev/null +++ b/vendors/irmin/test/ppx_irmin/test_logs-output.expected @@ -0,0 +1,5 @@ +[Line 2, characters 2-32] [App] Simple log entry +[Line 3, characters 2-45] [Error] Log entry on Line 3 +[Line 4, characters 2-49] [Warning] Infix @ operator: 3 +[Line 5, characters 2-76] [Info] Log entry in CPS form: Line 5, 3.140000 +[Line 12, characters 2-154] [Debug] Everything's OK on line 14 diff --git a/vendors/irmin/test/ppx_irmin/test_logs-processed.expected b/vendors/irmin/test/ppx_irmin/test_logs-processed.expected new file mode 100644 index 0000000000000000000000000000000000000000..a1beacece770ffbe31d8926b89aba0eab5b88a0f --- /dev/null +++ b/vendors/irmin/test/ppx_irmin/test_logs-processed.expected @@ -0,0 +1,62 @@ +let test () = + Logs.app + (fun f -> + f "Simple log entry" + ~tags:(Logs.Tag.add Ppx_irmin_internal_lib.Source_code_position.tag + __POS__ Logs.Tag.empty)); + Logs.err + (fun f -> + f "Log entry on Line %d" __LINE__ + ~tags:(Logs.Tag.add Ppx_irmin_internal_lib.Source_code_position.tag + __POS__ Logs.Tag.empty)); + Logs.warn + (fun f -> + f "Infix @@ operator: %d" (1 + 2) + ~tags:(Logs.Tag.add Ppx_irmin_internal_lib.Source_code_position.tag + __POS__ Logs.Tag.empty)); + Logs.info + (fun f -> + (fun f -> f "Log entry in CPS form: Line %d, %f" __LINE__ 3.14 : + (?header:string -> (_, _, _, _) format4 -> _) -> _) + (f + ~tags:(Logs.Tag.add + Ppx_irmin_internal_lib.Source_code_position.tag __POS__ + Logs.Tag.empty))); + Logs.debug + (fun f -> + (fun f -> + if true + then f "Everything's OK on line %d" __LINE__ + else f "Something's gone terribly wrong on line %d" __LINE__ : + (?header:string -> (_, _, _, _) format4 -> _) -> _) + (f + ~tags:(Logs.Tag.add + Ppx_irmin_internal_lib.Source_code_position.tag __POS__ + Logs.Tag.empty))); + () +let () = + let pp_source_pos ppf (_file, lnum, cnum, enum) = + Fmt.pf ppf "Line %d, characters %d-%d" lnum cnum enum in + let pp_level = + Fmt.of_to_string + (function + | Logs.App -> "App" + | Logs.Error -> "Error" + | Logs.Warning -> "Warning" + | Logs.Info -> "Info" + | Logs.Debug -> "Debug") in + let report _src level ~over k msgf = + let k _ = over (); k () in + msgf @@ + (fun ?header:_ -> + fun ?(tags= Logs.Tag.empty) -> + fun fmt -> + let source_pos = + Logs.Tag.find Ppx_irmin_internal_lib.Source_code_position.tag + tags in + (let open Fmt in kpf k stdout) + ("[%a] [%a] @[" ^^ (fmt ^^ "@]@.")) (Fmt.option pp_source_pos) + source_pos pp_level level) in + Logs.set_reporter { Logs.report = report }; + Logs.set_level (Some Debug); + test () diff --git a/vendors/irmin/test/ppx_irmin/test_logs.ml b/vendors/irmin/test/ppx_irmin/test_logs.ml new file mode 100644 index 0000000000000000000000000000000000000000..f1ad7d1a56328da5c2e6d1bbc5db2272f4edde40 --- /dev/null +++ b/vendors/irmin/test/ppx_irmin/test_logs.ml @@ -0,0 +1,46 @@ +let test () = + [%logs.app "Simple log entry"]; + [%logs.err "Log entry on Line %d" __LINE__]; + [%logs.warn "Infix @@ operator: %d" @@ (1 + 2)]; + [%logs.info fun f -> f "Log entry in CPS form: Line %d, %f" __LINE__ 3.14]; + + (* Test with a non-immediate application of [f] in the body. + + NOTE: The [Logs] API doesn't support polymorphic continuations: both + applications of [f] in the body must have the same number and type of + placeholders. *) + [%logs.debug + fun f -> + if true then f "Everything's OK on line %d" __LINE__ + else f "Something's gone terribly wrong on line %d" __LINE__]; + () + +(* Setup a reporter that can print tags added by the PPX, then run the tests. *) +let () = + let pp_source_pos ppf (_file, lnum, cnum, enum) = + Fmt.pf ppf "Line %d, characters %d-%d" lnum cnum enum + in + let pp_level = + Fmt.of_to_string (function + | Logs.App -> "App" + | Logs.Error -> "Error" + | Logs.Warning -> "Warning" + | Logs.Info -> "Info" + | Logs.Debug -> "Debug") + in + let report _src level ~over k msgf = + let k _ = + over (); + k () + in + msgf @@ fun ?header:_ ?(tags = Logs.Tag.empty) fmt -> + let source_pos = + Logs.Tag.find Ppx_irmin_internal_lib.Source_code_position.tag tags + in + Fmt.(kpf k stdout) + ("[%a] [%a] @[" ^^ fmt ^^ "@]@.") + (Fmt.option pp_source_pos) source_pos pp_level level + in + Logs.set_reporter { Logs.report }; + Logs.set_level (Some Debug); + test ()