diff --git a/.ocamlformat b/.ocamlformat index 73d0f7c58..2f597203f 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.15.0 +version=0.16.0 module-item-spacing=compact break-struct=natural break-infix=fit-or-vertical diff --git a/Makefile b/Makefile index 97716c3f9..704965edf 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -.PHONY: all test clean +.PHONY: all test clean fmt all: dune build @@ -8,3 +8,6 @@ test: clean: dune clean + +fmt: + dune build @fmt --auto-promote diff --git a/fuzz/smart.ml b/fuzz/smart.ml index d0c1f3f43..8b9e35fea 100644 --- a/fuzz/smart.ml +++ b/fuzz/smart.ml @@ -52,7 +52,7 @@ let ( >>= ) = Crowbar.dynamic_bind let () = let of_string str = - let ctx = Smart.make [] in + let ctx = Smart.Context.make [] in let state = Smart.decode ctx (Smart.packet ~trim:false) (fun _ctx res -> Return res) in @@ -85,7 +85,7 @@ let () = let () = let of_string str = - let ctx = Smart.make [] in + let ctx = Smart.Context.make [] in let state = Smart.decode ctx Smart.advertised_refs (fun _ctx res -> Return res) in @@ -105,7 +105,7 @@ let () = go state in let to_string v = - let ctx = Smart.make [] in + let ctx = Smart.Context.make [] in let buf = Buffer.create 0x1000 in let state = Smart.encode ctx Smart.send_advertised_refs v (fun _ctx -> diff --git a/src/carton-git/carton_git.ml b/src/carton-git/carton_git.ml index 1f3e4c5a8..621370a0e 100644 --- a/src/carton-git/carton_git.ml +++ b/src/carton-git/carton_git.ml @@ -95,7 +95,7 @@ struct | x :: r -> ( f a x >>= function | Ok a -> go a r - | Error x -> err x >>= fun () -> go a r ) + | Error x -> err x >>= fun () -> go a r) in go a l diff --git a/src/carton-git/carton_git_unix.ml b/src/carton-git/carton_git_unix.ml index 819473820..184b198ae 100644 --- a/src/carton-git/carton_git_unix.ml +++ b/src/carton-git/carton_git_unix.ml @@ -64,7 +64,7 @@ module Store = struct | entry -> ( match Fpath.of_string entry with | Ok x -> if Fpath.has_ext "pack" x then go (x :: acc) else go acc - | Error (`Msg _) -> (* ignore *) go acc )) + | Error (`Msg _) -> (* ignore *) go acc)) (function End_of_file -> Lwt.return acc | exn -> Lwt.fail exn) in go [] diff --git a/src/carton/dec.ml b/src/carton/dec.ml index 9486809ec..8f4c4f5f9 100644 --- a/src/carton/dec.ml +++ b/src/carton/dec.ml @@ -121,7 +121,7 @@ module Fp (Uid : UID) = struct Bigstringaf.blit d.i ~src_off:d.i_pos d.i ~dst_off:0 ~len:rem; (* compress *) let res = input_bigstring ic d.i rem (Bigstringaf.length d.i - rem) in - peek k (src d d.i 0 (rem + res)) ) + peek k (src d d.i 0 (rem + res))) else k d | `Manual -> let rem = i_rem d in @@ -129,7 +129,7 @@ module Fp (Uid : UID) = struct if rem < d.t_peek then ( Bigstringaf.blit d.i ~src_off:d.i_pos d.i ~dst_off:0 ~len:rem; (* compress *) - `Peek { d with k = peek k; i_pos = 0; i_len = rem - 1 } ) + `Peek { d with k = peek k; i_pos = 0; i_len = rem - 1 }) else k d let t_need d n = { d with t_need = n } @@ -467,7 +467,7 @@ module Fp (Uid : UID) = struct let _, dst_len = variable_length d.o x len in source := src_len; target := dst_len; - first := false ); + first := false); go (Zl.Inf.flush z) | `Malformed err -> `Malformed (Fmt.str "inflate: %s" err) @@ -478,7 +478,7 @@ module Fp (Uid : UID) = struct let _, dst_len = variable_length d.o x len in source := src_len; target := dst_len; - first := false ); + first := false); let len = i_rem d - Zl.Inf.src_rem z in let crc = Checkseum.Crc32.digest_bigstring d.i d.i_pos len crc in @@ -615,7 +615,7 @@ module W = struct available according the given offset. *) then ( slice := Some s; - raise_notrace Found ) + raise_notrace Found) | None -> () done; heavy_load s ~map t w @@ -686,7 +686,7 @@ let weight_of_delta : let decoder = Zh.M.src decoder slice.W.payload off len in (go [@tailcall]) Int64.(add slice.W.offset (of_int slice.W.length)) - decoder ) + decoder) in let off = Int64.(to_int (sub cursor slice.W.offset)) in let len = slice.W.length - off in @@ -716,7 +716,7 @@ let header_of_ref_delta ({ bind; return } as s) ~map t cursor slice = (sub (add !slice.W.offset (of_int !slice.W.length)) next_slice.W.offset))); - slice := next_slice ) + slice := next_slice) in return consume in @@ -730,7 +730,7 @@ let header_of_ref_delta ({ bind; return } as s) ~map t cursor slice = for _ = 0 to t.uid_ln - 1 do consume () done; - uid ) + uid) else let uid = Bytes.create t.uid_ln in for i = 0 to t.uid_ln - 1 do @@ -765,7 +765,7 @@ let header_of_ofs_delta ({ bind; return } as s) ~map t cursor slice = (sub (add !slice.W.offset (of_int !slice.W.length)) next_slice.W.offset))); - slice := next_slice ) + slice := next_slice) in return consume in @@ -806,7 +806,7 @@ let header_of_entry ({ bind; return } as s) ~map t cursor slice0 = (sub (add !slice.W.offset (of_int !slice.W.length)) next_slice.W.offset))); - slice := next_slice ) + slice := next_slice) in return consume in @@ -920,7 +920,7 @@ and weight_of_offset : ~visited ~cursor:Int64.(add slice.W.offset (of_int pos)) slice - | _ -> assert false ) + | _ -> assert false) type raw = { raw0 : Bigstringaf.t; raw1 : Bigstringaf.t; flip : bool } type v = { kind : kind; raw : raw; len : int; depth : int } @@ -997,7 +997,7 @@ let uncompress : decoder | None -> let decoder = Zl.Inf.src decoder Bigstringaf.empty 0 0 in - (go [@tailcall]) l p cursor decoder ) + (go [@tailcall]) l p cursor decoder) in let off = Int64.(to_int (sub cursor slice.W.offset)) in let len = slice.W.length - off in @@ -1044,7 +1044,7 @@ let of_delta : let decoder = Zh.M.src decoder slice.W.payload off len in (go [@tailcall]) Int64.(add slice.W.offset (of_int slice.W.length)) - raw decoder ) + raw decoder) in let off = Int64.(to_int (sub cursor slice.W.offset)) in let len = slice.W.length - off in @@ -1137,7 +1137,7 @@ and of_offset : of_ref_delta s ~map t raw ~cursor:Int64.(add slice.W.offset (of_int pos)) slice - | _ -> assert false ) + | _ -> assert false) type path = { path : int64 array; depth : int; kind : [ `A | `B | `C | `D ] } @@ -1227,7 +1227,7 @@ and fill_path_from_offset : (fill_path_from_ref_delta [@tailcall]) s ~map t ~depth path ~cursor:Int64.(add slice.W.offset (of_int pos)) slice - | _ -> assert false ) + | _ -> assert false) let path_of_offset : type fd uid s. @@ -1300,7 +1300,7 @@ let of_offset_with_source : of_delta s ~map t kind raw ~depth ~cursor:Int64.(add slice.W.offset (of_int pos)) slice - | _ -> assert false ) + | _ -> assert false) let base_of_offset : type fd uid s. @@ -1452,7 +1452,7 @@ let uid_of_offset_with_source : slice >>= fun ({ raw; _ } as v) -> return (digest ~kind ~len:v.len (get_payload raw)) - | _ -> assert false ) + | _ -> assert false) type 'uid node = Node of int64 * 'uid * 'uid node list | Leaf of int64 * 'uid @@ -1557,7 +1557,7 @@ struct | cursors -> nodes_of_offsets ~map ~oracle t ~kind (flip raw) ~depth:(succ depth) ~cursors - >>= fun nodes -> IO.return [ Node (cursor, uid, nodes) ] ) + >>= fun nodes -> IO.return [ Node (cursor, uid, nodes) ]) | cursors -> let source = get_source raw in let source = @@ -1627,7 +1627,7 @@ struct let raw' = make_raw ~weight:weight' in Bigstringaf.blit (get_payload raw) ~src_off:0 (get_payload raw') ~dst_off:0 ~len:weight; - raw' ) + raw') else raw in nodes_of_offsets ~map ~oracle t ~kind (flip raw) ~depth:1 ~cursors @@ -1687,7 +1687,7 @@ struct done; if mutex.v >= Array.length matrix then ( IO.Mutex.unlock mutex.m; - IO.return () ) + IO.return ()) else let root = mutex.v in mutex.v <- mutex.v + 1; @@ -1777,7 +1777,7 @@ struct finish := true; IO.Condition.broadcast signal; IO.Mutex.unlock mutex; - return () ) + return ()) else ( incr p; let uid = Idx.get_uid idx v @@ -1788,7 +1788,7 @@ struct IO.Condition.signal signal; IO.Mutex.unlock mutex; - go () ) + go ()) in go () diff --git a/src/carton/enc.ml b/src/carton/enc.ml index 961864caf..9f3178a1f 100644 --- a/src/carton/enc.ml +++ b/src/carton/enc.ml @@ -47,7 +47,8 @@ module Utils = struct length_of_variable_length source + length_of_variable_length target + List.fold_left - (fun acc -> function Duff.Insert (_, len) -> 1 + len + acc + (fun acc -> function + | Duff.Insert (_, len) -> 1 + len + acc | Duff.Copy (off, len) -> 1 + length_of_copy_code ~off ~len + acc) 0 hunks end @@ -143,7 +144,7 @@ let entry_to_target : let ( >>= ) = bind in load entry.uid >>= fun v -> - ( match entry.delta with + (match entry.delta with | From uid -> load uid >>= fun s -> let source = Bigstringaf.sub ~off:0 ~len:(Dec.len s) (Dec.raw s) in @@ -160,7 +161,7 @@ let entry_to_target : source = uid; source_length = Dec.len s; }) - | Zero -> return None ) + | Zero -> return None) >>= fun patch -> return { patch; entry; v = W.create_with v } let length_of_delta ~source ~target hunks = Utils.length ~source ~target hunks @@ -322,7 +323,7 @@ struct match window.(j) with | Some m -> ( try try_delta j m >>= fun () -> (go [@tailcall]) (pred j) - with Break -> return () ) + with Break -> return ()) | None -> return () (* TODO: check it! *) in @@ -358,11 +359,11 @@ struct v := (!v + 1) mod weight done; - window.(!v) <- swap ); + window.(!v) <- swap); if depth_of_target targets.(n) < _max_depth then (iter [@tailcall]) (succ n) (if idx + 1 >= weight then 0 else idx + 1) - else (iter [@tailcall]) (succ n) idx ) + else (iter [@tailcall]) (succ n) idx) else return () in iter 0 0 @@ -382,12 +383,12 @@ struct mutex.v <- mutex.v + 1; if v >= Array.length entries then ( IO.Mutex.unlock mutex.m; - IO.return () ) + IO.return ()) else ( IO.Mutex.unlock mutex.m; entry_to_target s ~load entries.(v) |> Scheduler.prj >>= fun target -> targets.(v) <- Some target; - go () ) + go ()) in go () @@ -441,11 +442,11 @@ end = struct | Z encoder -> ( match encode_zlib ~o encoder with | `Flush (encoder, len) -> `Flush (Z encoder, len) - | `End -> `End ) + | `End -> `End) | H encoder -> ( match encode_hunk ~o encoder with | `Flush (encoder, len) -> `Flush (H encoder, len) - | `End -> `End ) + | `End -> `End) let dst encoder s j l = match encoder with @@ -586,4 +587,4 @@ let encode_target : >>= fun encoder -> let off = off + uid.uid_ln in let len = Bigstringaf.length b.o - off in - return (off, N.dst encoder b.o off len) ) + return (off, N.dst encoder b.o off len)) diff --git a/src/carton/h.ml b/src/carton/h.ml index 02696c025..ecb47f886 100644 --- a/src/carton/h.ml +++ b/src/carton/h.ml @@ -191,7 +191,7 @@ module M = struct else ( d.i <- s; d.i_pos <- j; - d.i_len <- j + l - 1 ) + d.i_len <- j + l - 1) let dst d s j l = match d.s with @@ -201,7 +201,7 @@ module M = struct else ( d.dst <- s; d.o_pos <- j; - if bigstring_length d.source >= d.src_len then d.s <- Cmd ) + if bigstring_length d.source >= d.src_len then d.s <- Cmd) | _ -> Fmt.invalid_arg "Invalid call of dst" let pp_state ppf = function @@ -245,10 +245,10 @@ module M = struct let need = d.t_need - d.t_len in if rem < need then ( blit d rem; - refill (t_fill k) d ) + refill (t_fill k) d) else ( blit d need; - k d ) + k d) let required = let a = [| 0; 1; 1; 2; 1; 2; 2; 3; 1; 2; 2; 3; 2; 3; 3; 4 |] in @@ -281,31 +281,31 @@ module M = struct if command land 0x01 != 0 then ( let v = unsafe_get_uint8 i !p in cp_off := v; - incr p ); + incr p); if command land 0x02 != 0 then ( let v = unsafe_get_uint8 i !p in cp_off := !cp_off lor (v lsl 8); - incr p ); + incr p); if command land 0x04 != 0 then ( let v = unsafe_get_uint8 i !p in cp_off := !cp_off lor (v lsl 16); - incr p ); + incr p); if command land 0x08 != 0 then ( let v = unsafe_get_uint8 i !p in cp_off := !cp_off lor (v lsl 24); - incr p ); + incr p); if command land 0x10 != 0 then ( let v = unsafe_get_uint8 i !p in cp_len := v; - incr p ); + incr p); if command land 0x20 != 0 then ( let v = unsafe_get_uint8 i !p in cp_len := !cp_len lor (v lsl 8); - incr p ); + incr p); if command land 0x40 != 0 then ( let v = unsafe_get_uint8 i !p in cp_len := !cp_len lor (v lsl 16); - incr p ); + incr p); if !cp_len == 0 then cp_len := 0x10000; unsafe_blit d.source !cp_off d.dst d.o_pos !cp_len; @@ -324,14 +324,14 @@ module M = struct d.o_pos <- d.o_pos + len; d.s <- Cmd; d.k <- decode_k; - decode_k d ) + decode_k d) else ( unsafe_blit d.i d.i_pos d.dst d.o_pos len; d.i_pos <- d.i_pos + len; d.o_pos <- d.o_pos + len; d.s <- Cmd; d.k <- decode_k; - decode_k d ) + decode_k d) and cmd d = let c = unsafe_get_uint8 d.i d.i_pos in @@ -344,7 +344,7 @@ module M = struct if enough d then if c land 0x80 != 0 then cp d else it d else ( t_need d (need d); - t_fill (if c land 0x80 != 0 then cp else it) d ) ) + t_fill (if c land 0x80 != 0 then cp else it) d)) and decode_k d = let rem = i_rem d in @@ -373,12 +373,12 @@ module M = struct if required (cmd land 0x7f) <= rem then cp d else ( t_need d (need d); - t_fill cp d ) + t_fill cp d) | It len -> if len <= rem then it d else ( t_need d (need d); - t_fill it d ) + t_fill it d) let decode d = match d.k d with @@ -494,10 +494,10 @@ module N = struct if rem < len then ( blit e rem; - flush (t_flush k) e ) + flush (t_flush k) e) else ( blit e len; - k e ) + k e) let rec encode_contents e v = let k e = @@ -514,7 +514,7 @@ module N = struct let s, j, k = if rem < required then ( t_range e (required - 1); - e.t, 0, t_flush k ) + e.t, 0, t_flush k) else let j = e.o_pos in e.o_pos <- e.o_pos + required; @@ -527,14 +527,14 @@ module N = struct while !off <> 0 do if !off land 0xff != 0 then ( unsafe_set_uint8 s !pos !off; - incr pos ); + incr pos); off := !off asr 8 done; let len = ref len in while !len <> 0 do if !len land 0xff != 0 then ( unsafe_set_uint8 s !pos !len; - incr pos ); + incr pos); len := !len asr 8 done; k e @@ -545,7 +545,7 @@ module N = struct let s, j, k = if rem < required then ( t_range e (required - 1); - e.t, 0, t_flush k ) + e.t, 0, t_flush k) else let j = e.o_pos in e.o_pos <- e.o_pos + required; @@ -591,12 +591,12 @@ module N = struct store_variable_length e.o e.o_pos e.src_len; store_variable_length e.o (e.o_pos + needed e.src_len) e.dst_len; e.o_pos <- e.o_pos + ndd; - k e ) + k e) else ( t_range e ndd; store_variable_length e.t 0 e.src_len; store_variable_length e.t (needed e.src_len) e.dst_len; - t_flush k e ) + t_flush k e) let encode e v = e.k e v diff --git a/src/carton/idx.ml b/src/carton/idx.ml index c248e9f1a..32816da16 100644 --- a/src/carton/idx.ml +++ b/src/carton/idx.ml @@ -317,10 +317,10 @@ end = struct let flush = if with_ctx then flush_with_ctx else flush_without_ctx in if rem < len then ( blit e rem; - flush (t_flush k) e ) + flush (t_flush k) e) else ( blit e len; - k e ) + k e) let ok e = e.k <- (fun _ `Await -> `Ok); @@ -333,7 +333,7 @@ end = struct let s, j, k = if rem < Uid.length then ( t_range e (Uid.length - 1); - e.t, 0, t_flush ~with_ctx:false k2 ) + e.t, 0, t_flush ~with_ctx:false k2) else let j = e.o_pos in e.o_pos <- e.o_pos + Uid.length; @@ -349,7 +349,7 @@ end = struct let s, j, k = if rem < Uid.length then ( t_range e (Uid.length - 1); - e.t, 0, t_flush k0 ) + e.t, 0, t_flush k0) else let j = e.o_pos in e.o_pos <- e.o_pos + Uid.length; @@ -363,17 +363,17 @@ end = struct let k e = if e.n + 1 == Array.length e.index then ( e.n <- 0; - encode_trail e `Await ) + encode_trail e `Await) else ( e.n <- succ e.n; - encode_offset e `Await ) + encode_offset e `Await) in let rem = o_rem e in let s, j, k = if rem < 4 then ( t_range e 3; - e.t, 0, t_flush k ) + e.t, 0, t_flush k) else let j = e.o_pos in e.o_pos <- e.o_pos + 4; @@ -387,17 +387,17 @@ end = struct let k e = if e.n + 1 == Array.length e.index then ( e.n <- 0; - encode_offset e `Await ) + encode_offset e `Await) else ( e.n <- succ e.n; - encode_crc e `Await ) + encode_crc e `Await) in let rem = o_rem e in let s, j, k = if rem < 4 then ( t_range e 3; - e.t, 0, t_flush k ) + e.t, 0, t_flush k) else let j = e.o_pos in e.o_pos <- e.o_pos + 4; @@ -411,17 +411,17 @@ end = struct let k e = if e.n + 1 == Array.length e.index then ( e.n <- 0; - encode_crc e `Await ) + encode_crc e `Await) else ( e.n <- succ e.n; - encode_hash e `Await ) + encode_hash e `Await) in let rem = o_rem e in let s, j, k = if rem < Uid.length then ( t_range e (Uid.length - 1); - e.t, 0, t_flush k ) + e.t, 0, t_flush k) else let j = e.o_pos in e.o_pos <- e.o_pos + Uid.length; @@ -438,17 +438,17 @@ end = struct if e.n + 1 == 256 then ( e.n <- 0; if Array.length e.index > 0 then encode_hash e `Await - else encode_trail e `Await ) + else encode_trail e `Await) else ( e.n <- succ e.n; - encode_fanout e `Await ) + encode_fanout e `Await) in let rem = o_rem e in let s, j, k = if rem < 4 then ( t_range e 3; - e.t, 0, t_flush k ) + e.t, 0, t_flush k) else let j = e.o_pos in e.o_pos <- e.o_pos + 4; @@ -473,7 +473,7 @@ end = struct let s, j, k = if rem < 8 then ( t_range e 8; - e.t, 0, t_flush k ) + e.t, 0, t_flush k) else let j = e.o_pos in e.o_pos <- e.o_pos + 8; @@ -609,8 +609,8 @@ struct let close tbl fd = let result = Bigstringaf.sub fd.buffer ~off:0 ~len:fd.length in - ( match Ephemeron.K1.get_data tbl with + (match Ephemeron.K1.get_data tbl with | Some value -> value := result - | None -> assert false ); + | None -> assert false); IO.return (Ok ()) end diff --git a/src/carton/thin.ml b/src/carton/thin.ml index 7dc8bd70c..18fa8b197 100644 --- a/src/carton/thin.ml +++ b/src/carton/thin.ml @@ -42,7 +42,7 @@ struct Ke.Rke.N.push ke ~blit:blit_from_string ~length:String.length ~off ~len src; go filled inputs - | None -> return filled ) + | None -> return filled) | src :: _ -> let src = Cstruct.of_bigarray src in let len = min (Cstruct.len inputs) (Cstruct.len src) in @@ -68,7 +68,7 @@ struct let rec go rest raw = if rest <= 0 then ( Cstruct.blit_to_bytes fl_buffer 0 buf off len; - return (abs rest + len) ) + return (abs rest + len)) else read_cstruct 0 raw >>= function | 0 -> @@ -130,17 +130,17 @@ struct Hashtbl.add where offset n; Hashtbl.add checks offset crc; - ( try - let vs = - Hashtbl.find children (`Ofs Int64.(sub offset (of_int s))) - in - Hashtbl.replace children - (`Ofs Int64.(sub offset (of_int s))) - (offset :: vs) - with Not_found -> - Hashtbl.add children - (`Ofs Int64.(sub offset (of_int s))) - [ offset ] ); + (try + let vs = + Hashtbl.find children (`Ofs Int64.(sub offset (of_int s))) + in + Hashtbl.replace children + (`Ofs Int64.(sub offset (of_int s))) + (offset :: vs) + with Not_found -> + Hashtbl.add children + (`Ofs Int64.(sub offset (of_int s))) + [ offset ]); go decoder | `Entry ({ Fp.kind = Ref { ptr; target; source }; offset; crc; _ }, decoder) @@ -153,10 +153,10 @@ struct Hashtbl.add where offset n; Hashtbl.add checks offset crc; - ( try - let vs = Hashtbl.find children (`Ref ptr) in - Hashtbl.replace children (`Ref ptr) (offset :: vs) - with Not_found -> Hashtbl.add children (`Ref ptr) [ offset ] ); + (try + let vs = Hashtbl.find children (`Ref ptr) in + Hashtbl.replace children (`Ref ptr) (offset :: vs) + with Not_found -> Hashtbl.add children (`Ref ptr) [ offset ]); go decoder | `End uid -> return (Ok uid) | `Malformed err -> diff --git a/src/carton/zh.ml b/src/carton/zh.ml index 03cbc73e7..fe128872f 100644 --- a/src/carton/zh.ml +++ b/src/carton/zh.ml @@ -72,7 +72,7 @@ end = struct encode_z { e with z } | d -> H.N.dst e.h e.t 0 (De.bigstring_length e.t); - encode_h e d ) + encode_h e d) and encode_h e d = let v, d = match d with v :: d -> v, d | [] -> `End, [] in diff --git a/src/git-index/git_index.ml b/src/git-index/git_index.ml index 7486379af..59ac6ebb5 100644 --- a/src/git-index/git_index.ml +++ b/src/git-index/git_index.ml @@ -182,11 +182,11 @@ module Entry = struct let mtime_sec = Float.to_int mtime_sec in let mtime_nsec = Float.to_int (mtime_nsec *. 1_000_000_000.) in let open Rresult in - ( match stat.Unix.st_kind with + (match stat.Unix.st_kind with | Unix.S_DIR -> Fmt.invalid_arg "Git sub-module are not implemented" | Unix.S_REG -> oid_of_blob ~hash path | Unix.S_LNK -> oid_of_link ~hash path - | _kind -> Fmt.invalid_arg "Invalid kind" ) + | _kind -> Fmt.invalid_arg "Invalid kind") >>| fun oid -> { ce_stat = @@ -392,7 +392,7 @@ module Entry = struct Bigstringaf.set_int16_be ce_payload (40 + Hash.digest_size + 2) (flags asr 16); - ce_payload ) + ce_payload) else Bigstringaf.sub ce_payload ~off:0 ~len:(40 + Hash.digest_size + 2) in @@ -543,7 +543,7 @@ let rem : Fpath.t -> 'oid t -> unit = (fun i -> if i < pos then t.entries.(i) else t.entries.(i + 1)) in t.entries <- res; - go pos ) + go pos) in go pos @@ -770,8 +770,7 @@ let store : if t.entries.(i).ce_flags land Entry._ce_extended_flags <> 0 then ( v := true; - t.entries.(i).ce_flags <- t.entries.(i).ce_flags lor Entry._ce_extended - ) + t.entries.(i).ce_flags <- t.entries.(i).ce_flags lor Entry._ce_extended) done; !v in diff --git a/src/git-unix/git_unix.ml b/src/git-unix/git_unix.ml index c6c17cb6b..80978bbd4 100644 --- a/src/git-unix/git_unix.ml +++ b/src/git-unix/git_unix.ml @@ -50,7 +50,7 @@ module Fold = struct | Some f when dotfiles || not (f.[0] = '.') -> ( match Fpath.of_string f with | Ok f -> readdir dh ((if rel then f else Fpath.(dir // f)) :: acc) - | Error (`Msg _) -> (* ignore *) readdir dh acc ) + | Error (`Msg _) -> (* ignore *) readdir dh acc) | Some _ -> readdir dh acc in Lwt.catch @@ -302,7 +302,7 @@ module Minor_heap (Digestif : Digestif.S) = struct | tl :: hd :: _ -> ( match Digestif.of_hex (hd ^ tl) with | _ -> Fold.file_exists path - | exception _ -> Lwt.return false ) + | exception _ -> Lwt.return false) | _ -> Lwt.return false in Fold.fold ~dotfiles:false ~elements:(`Sat elements) f [] root @@ -491,7 +491,7 @@ module Unix = struct | [] -> Lwt.return_ok () in dirs_to_create dir [] >>? fun dirs -> - create_them dirs () >>? fun () -> Lwt.return_ok true ) + create_them dirs () >>? fun () -> Lwt.return_ok true) end module Reference_heap = struct @@ -530,8 +530,8 @@ module Reference_heap = struct let open Rresult in Bos.OS.Dir.create ~path:true base >>= fun _ -> Bos.OS.Dir.exists path >>= fun res -> - ( if res then Bos.OS.Dir.delete ~must_exist:false ~recurse:true path - else R.ok () ) + (if res then Bos.OS.Dir.delete ~must_exist:false ~recurse:true path + else R.ok ()) >>= fun () -> Bos.OS.File.tmp "git-reference-%s" >>= fun src -> Bos.OS.File.write src str >>= fun () -> @@ -570,7 +570,7 @@ module Reference_heap = struct Log.debug (fun l -> l "%a exists into the store." Fpath.pp x); match Git.Reference.of_string (Fpath.to_string x) with | Ok x -> x :: r - | Error _ -> r ) + | Error _ -> r) | None -> assert false (* XXX(dinosaure): see [elements]. *) in @@ -655,9 +655,10 @@ module Sync (Git_store : Git.S) (HTTP : Smart_git.HTTP) = struct module Log = (val Logs.src_log src : Logs.LOG) - include Git.Sync.Make (Git_store.Hash) (Major_heap) (Major_heap) (Conduit_lwt) - (Git_store) - (HTTP) + include + Git.Sync.Make (Git_store.Hash) (Major_heap) (Major_heap) (Conduit_lwt) + (Git_store) + (HTTP) let random_gen = lazy (Random.State.make_self_init ()) diff --git a/src/git-unix/ogit-fetch/main.ml b/src/git-unix/ogit-fetch/main.ml index 07749e9d5..dc7c39422 100644 --- a/src/git-unix/ogit-fetch/main.ml +++ b/src/git-unix/ogit-fetch/main.ml @@ -68,7 +68,7 @@ let ssh_cfg edn ssh_seed = assert (String.length ssh_seed > 0); let key = Awa.Keys.of_seed ssh_seed in match edn with - | { Smart_git.scheme = `SSH user; path; _ } -> + | { Smart_git.Endpoint.scheme = `SSH user; path; _ } -> let req = Awa.Ssh.Exec (Fmt.str "git-upload-pack '%s'" path) in Some { Awa_conduit.user; key; req; authenticator = None } | _ -> None @@ -81,7 +81,7 @@ let ssh_resolve (ssh_cfg : Awa_conduit.endpoint) domain_name = let main (ssh_seed : string) (references : (Git.Reference.t * Git.Reference.t) list) (directory : string) - (repository : Smart_git.endpoint) : (unit, 'error) Lwt_result.t = + (repository : Smart_git.Endpoint.t) : (unit, 'error) Lwt_result.t = let repo_root = (match directory with "" -> Sys.getcwd () | _ -> directory) |> Fpath.v in @@ -149,8 +149,8 @@ module Flag = struct (** passed argument needs to be a URI of the repository *) let repository = let endpoint = - let parse = Smart_git.endpoint_of_string in - let print = Smart_git.pp_endpoint in + let parse = Smart_git.Endpoint.of_string in + let print = Smart_git.Endpoint.pp in Arg.conv ~docv:"" (parse, print) in let doc = "URI leading to repository" in @@ -189,13 +189,13 @@ let command = let exits = Term.default_exits in ( Term.( ret - ( const main + (const main $ Flag.progress $ Flag.ssh_seed $ Flag.references $ Flag.directory $ Flag.repository - $ setup_log )), + $ setup_log)), Term.info "ogit-fetch" ~version:"v0.1" ~doc ~exits ) let () = Term.(exit @@ eval command) diff --git a/src/git/cstruct_append.ml b/src/git/cstruct_append.ml index c67c4004b..b71f5b1bd 100644 --- a/src/git/cstruct_append.ml +++ b/src/git/cstruct_append.ml @@ -45,12 +45,12 @@ let key tbl = Ephemeron.K1.set_key tbl.o0 value; Ephemeron.K1.set_data tbl.o0 (ref empty); tbl.which <- not tbl.which; - value ) + value) else ( Ephemeron.K1.set_key tbl.o1 value; Ephemeron.K1.set_data tbl.o1 (ref empty); tbl.which <- not tbl.which; - value ) + value) [@@inline never] type uid = key ref @@ -117,7 +117,7 @@ let create ~mode:_ { o0; o1; _ } key = if Cstruct.len !value < 1 then ( let v = Cstruct.create 1 in value := v; - v ) + v) else !value in @@ -155,14 +155,14 @@ let close tbl fd = Log.debug (fun m -> m "Close the object into the cstruct-append heap (save %d bytes)." fd.length); - ( if fd.which then - match Ephemeron.K1.get_data tbl.o0 with - | Some value -> value := result - | None -> assert false + (if fd.which then + match Ephemeron.K1.get_data tbl.o0 with + | Some value -> value := result + | None -> assert false else match Ephemeron.K1.get_data tbl.o1 with | Some value -> value := result - | None -> assert false ); + | None -> assert false); Lwt.return_ok () let move tbl ~src ~dst = @@ -177,7 +177,7 @@ let move tbl ~src ~dst = else if src == k1 && dst == k0 then v0 := !v1 else ( Log.err (fun m -> m "Given keys are wrong!"); - assert false ); + assert false); Lwt.return_ok () | _ -> Log.err (fun m -> m "One object was deleted by the garbage collector."); diff --git a/src/git/dune b/src/git/dune index 193afbe31..bd1b1f5d1 100644 --- a/src/git/dune +++ b/src/git/dune @@ -4,4 +4,5 @@ (libraries stdlib-shims rresult git-nss.sigs git-nss.pck bigarray-compat optint loose decompress.de decompress.zl result git-nss.smart conduit logs lwt cstruct angstrom bigstringaf carton ke fmt checkseum git-nss.git - ocamlgraph astring fpath loose_git carton-lwt carton-git digestif encore)) + git-nss.hkt ocamlgraph astring fpath loose_git carton-lwt carton-git + digestif encore)) diff --git a/src/git/mem.ml b/src/git/mem.ml index 1fc435c0b..71e983c02 100644 --- a/src/git/mem.ml +++ b/src/git/mem.ml @@ -127,7 +127,7 @@ module Make (Digestif : Digestif.S) = struct include ( Reference : module type of Reference - with type 'uid contents := 'uid Reference.contents ) + with type 'uid contents := 'uid Reference.contents) type contents = hash Reference.contents end @@ -179,18 +179,18 @@ module Make (Digestif : Digestif.S) = struct if Hashtbl.mem t.values hash then Lwt.return (Ok (hash, 0)) else ( Hashtbl.add t.values hash (lazy value); - Lwt.return_ok (hash, Int64.to_int (Value.length value)) ) + Lwt.return_ok (hash, Int64.to_int (Value.length value))) let digest kind raw = let len = Cstruct.len raw in let ctx = Hash.init () in let hdr = Fmt.str "%s %d\000%!" - ( match kind with + (match kind with | `Commit -> "commit" | `Blob -> "blob" | `Tree -> "tree" - | `Tag -> "tag" ) + | `Tag -> "tag") len in let ctx = Hash.feed_string ctx hdr in @@ -204,11 +204,11 @@ module Make (Digestif : Digestif.S) = struct else let value = lazy - ( match Value.of_raw ~kind inflated with + (match Value.of_raw ~kind inflated with | Error (`Msg err) -> let str = Fmt.str "Value.of_raw(%a): %s" Hash.pp hash err in raise (Failure str) - | Ok value -> value ) + | Ok value -> value) in Hashtbl.add t.inflated hash (kind, inflated); Hashtbl.add t.values hash value; @@ -230,7 +230,7 @@ module Make (Digestif : Digestif.S) = struct try let kind, raw = Hashtbl.find t.inflated h in Lwt.return_some (kind, raw) - with Not_found -> Lwt.return_none ) + with Not_found -> Lwt.return_none) let read t h = try Ok (Lazy.force (Hashtbl.find t.values h)) @@ -244,7 +244,7 @@ module Make (Digestif : Digestif.S) = struct | Error (`Msg err) -> let str = Fmt.str "Value.of_raw(%a): %s" Hash.pp h err in raise (Failure str) - with Not_found -> Error (`Not_found h) ) + with Not_found -> Error (`Not_found h)) let keys t = Hashtbl.fold (fun k _ l -> k :: l) t [] @@ -346,7 +346,8 @@ module Make (Digestif : Digestif.S) = struct Log.debug (fun l -> l "Ref.list."); let graph, rest = Hashtbl.fold - (fun k -> function `R ptr -> fun (a, r) -> a, (k, ptr) :: r + (fun k -> function + | `R ptr -> fun (a, r) -> a, (k, ptr) :: r | `H hash -> fun (a, r) -> Graph.add k hash a, r) t.refs (Graph.empty, []) in @@ -458,9 +459,9 @@ struct let map _ _ ~pos:_ _ = assert false end - include Sync.Make (Git_store.Hash) (Cstruct_append) (Index) (Conduit) - (Git_store) - (HTTP) + include + Sync.Make (Git_store.Hash) (Cstruct_append) (Index) (Conduit) (Git_store) + (HTTP) let stream_of_cstruct ?(chunk = 0x1000) payload = let stream, emitter = Lwt_stream.create () in @@ -468,7 +469,7 @@ struct let rec go pos = if pos = Cstruct.len payload then ( emitter None; - Lwt.return_unit ) + Lwt.return_unit) else let len = min chunk (Cstruct.len payload - pos) in let tmp = Bytes.create len in diff --git a/src/git/object_graph.ml b/src/git/object_graph.ml index 330e4bc79..c0fec9579 100644 --- a/src/git/object_graph.ml +++ b/src/git/object_graph.ml @@ -205,7 +205,7 @@ struct Search.pred ~full t key >>= fun preds -> let keys = List.map (fun x -> snd (label x)) preds in List.iter (fun k -> K.add_edge g k key) keys; - Lwt_list.iter_p add keys ) + Lwt_list.iter_p add keys) in let max = S.fold (fun x a -> x :: a) max [] in Lwt_list.iter_p add max >>= fun () -> Lwt.return g diff --git a/src/git/reference.ml b/src/git/reference.ml index e6d9b071f..56efbdb24 100644 --- a/src/git/reference.ml +++ b/src/git/reference.ml @@ -21,10 +21,10 @@ let validate_and_collapse_seps p = if c = '\x00' then error_msgf "Malformed reference: %S" p else if c <> dir_sep_char then ( Bytes.set b k c; - with_buf b false (k + 1) (i + 1) ) + with_buf b false (k + 1) (i + 1)) else if not last_sep then ( Bytes.set b k c; - with_buf b true (k + 1) (i + 1) ) + with_buf b true (k + 1) (i + 1)) else with_buf b true k (i + 1) in let rec try_no_alloc last_sep i = @@ -139,7 +139,7 @@ module Packed = struct let reference = v reference in let uid = of_hex uid in go (Ref (reference, uid) :: acc) - | None -> go acc ) ) + | None -> go acc)) | None -> return (List.rev acc) in go [] @@ -152,7 +152,7 @@ module Packed = struct | Ref (reference', _) -> if equal reference reference' then ( res := true; - raise Found ) + raise Found) | _ -> () in (try List.iter f packed with Found -> ()); @@ -164,7 +164,7 @@ module Packed = struct | Ref (reference', uid) -> if equal reference reference' then ( res := Some uid; - raise Found ) + raise Found) | _ -> () in (try List.iter f packed with Found -> ()); @@ -188,7 +188,7 @@ type ('t, 'uid, 'error, 's) store = { packed : 'uid Packed.packed; } -let reword_error f = function Ok v -> Ok v | Error err -> Error (f err) +let reword_error f = function Ok _ as o -> o | Error err -> Error (f err) let contents store str = match store.uid_of_hex (String.trim str) with @@ -197,7 +197,7 @@ let contents store str = let is_sep chr = Astring.Char.Ascii.is_white chr || chr = ':' in match Astring.String.fields ~empty:false ~is_sep str with | [ _ref; value ] -> Ref (v value) - | _ -> Fmt.invalid_arg "Invalid reference contents: %S" str ) + | _ -> Fmt.invalid_arg "Invalid reference contents: %S" str) let resolve { Carton.bind; Carton.return } t store reference = let ( >>= ) = bind in @@ -207,13 +207,13 @@ let resolve { Carton.bind; Carton.return } t store reference = | Error _ -> ( match Packed.get reference store.packed with | Some uid -> return (Ok uid) - | None -> return (Error (`Not_found reference)) ) + | None -> return (Error (`Not_found reference))) | Ok str -> ( match contents store str with | Uid uid -> return (Ok uid) | Ref reference -> if List.exists (equal reference) visited then return (Error `Cycle) - else go (reference :: visited) reference ) + else go (reference :: visited) reference) in go [ reference ] reference @@ -224,7 +224,7 @@ let read { Carton.bind; Carton.return } t store reference = | Error _ -> ( match Packed.get reference store.packed with | Some uid -> return (Ok (Uid uid)) - | None -> return (Error (`Not_found reference)) ) + | None -> return (Error (`Not_found reference))) | Ok str -> return (Ok (contents store str)) let write { Carton.bind; Carton.return } t store reference contents = diff --git a/src/git/search.ml b/src/git/search.ml index 6dbadc8d5..7af9d6a32 100644 --- a/src/git/search.ml +++ b/src/git/search.ml @@ -47,7 +47,7 @@ struct if full then [ `Tree_root (Store.Value.Commit.tree c) ] else [] | false -> (if full then [ `Tree_root (Store.Value.Commit.tree c) ] else []) - @ List.map (fun x -> `Commit x) (Store.Value.Commit.parents c) ) + @ List.map (fun x -> `Commit x) (Store.Value.Commit.parents c)) | Value.Tag t -> if full then Lwt.return [ tag t ] else Lwt.return [] | Value.Tree t -> if full then @@ -86,17 +86,17 @@ struct pred t hash >>= fun preds -> match find_tag l preds with | None -> Lwt.return_none - | Some s -> (find [@tailcall]) t s p ) + | Some s -> (find [@tailcall]) t s p) | `Commit p -> ( pred t hash >>= fun preds -> match find_tree_root preds with | None -> Lwt.return_none - | Some s -> (find [@tailcall]) t s p ) + | Some s -> (find [@tailcall]) t s p) | `Path (h :: p) -> ( pred t hash >>= fun preds -> match find_tree h preds with | None -> Lwt.return_none - | Some s -> (find [@tailcall]) t s (`Path p) ) + | Some s -> (find [@tailcall]) t s (`Path p)) (* XXX: can do one less look-up *) let mem t h path = diff --git a/src/git/store.ml b/src/git/store.ml index c97808c84..da3b3fefc 100644 --- a/src/git/store.ml +++ b/src/git/store.ml @@ -84,7 +84,7 @@ struct include ( Reference : module type of Reference - with type 'uid contents := 'uid Reference.contents ) + with type 'uid contents := 'uid Reference.contents) type contents = hash Reference.contents end @@ -103,8 +103,8 @@ struct major_uid : (hash, Mj.uid, Mj.t) major; packs : (Mj.uid, < rd : unit > Mj.fd, Hash.t) Carton_git.t; pools : - ( (< rd : unit > Mj.fd * int64) - * (< rd : unit > Mj.fd * int64) Carton_git.buffers Lwt_pool.t ) + ((< rd : unit > Mj.fd * int64) + * (< rd : unit > Mj.fd * int64) Carton_git.buffers Lwt_pool.t) list; buffs : buffers Lwt_pool.t; rs : Rs.t; @@ -213,7 +213,7 @@ struct | Error `Non_atomic -> ( Loose.get t.minor buffers hash >>= function | Ok v -> Lwt.return_some v - | Error _ -> Lwt.return_none ) ) + | Error _ -> Lwt.return_none)) let read t hash = read_inflated t hash >>= function @@ -279,7 +279,7 @@ struct let stream = stream_of_raw raw in Loose.add t.minor buffers (kind, length) stream >>= function | Ok _ as v -> Lwt.return v - | Error (`Store err) -> Lwt.return_error (`Minor err) ) + | Error (`Store err) -> Lwt.return_error (`Minor err)) let read_inflated t hash = read_inflated t hash >>= function @@ -315,12 +315,12 @@ struct if !consumed then Lwt.return_none else ( consumed := true; - Lwt.return_some (Bigstringaf.to_string raw) ) + Lwt.return_some (Bigstringaf.to_string raw)) in Loose.add t.minor buffers (kind, Int64.of_int len) stream >>= function | Ok (hash, _) -> Lwt.return hash | Error (`Store err) -> - Lwt.fail (Failure (Fmt.str "%a" pp_error (`Minor err))) ) + Lwt.fail (Failure (Fmt.str "%a" pp_error (`Minor err)))) let mem t hash = if not (Pack.exists t.major t.packs hash) then Loose.exists t.minor hash @@ -453,7 +453,7 @@ struct let res = Rresult.R.reword_error (fun err -> `Ref err) res in if Packed.exists refname t.refs.packed then ( t.refs <- { t.refs with packed = Packed.remove refname t.refs.packed }; - Lwt.return res ) + Lwt.return res) else Lwt.return res end diff --git a/src/git/sync.ml b/src/git/sync.ml index ee36fc2a2..a86cfd89d 100644 --- a/src/git/sync.ml +++ b/src/git/sync.ml @@ -31,7 +31,7 @@ module type S = sig ?push_stdout:(string -> unit) -> ?push_stderr:(string -> unit) -> resolvers:Conduit.resolvers -> - Smart_git.endpoint -> + Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> ?capabilities:Smart.Capability.t list -> @@ -41,7 +41,7 @@ module type S = sig val push : resolvers:Conduit.resolvers -> - Smart_git.endpoint -> + Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> ?capabilities:Smart.Capability.t list -> @@ -76,9 +76,9 @@ struct | `Store err -> Fmt.pf ppf "Store error: %a" Store.pp_error err module Hash = Hash.Make (Digestif) - module Scheduler = Sigs.Make_sched (Lwt) + module Scheduler = Hkt.Make_sched (Lwt) - module Ministore = Sigs.Make_store (struct + module Ministore = Hkt.Make_store (struct type ('k, 'v) t = Store.t * ('k, 'v) Hashtbl.t (* constraint 'k = Digestif.t *) @@ -103,7 +103,7 @@ struct let v = hash, ref 0, ts in Hashtbl.add hashtbl hash v; Lwt.return_some v - | Ok _ | Error _ -> Lwt.return_none ) + | Ok _ | Error _ -> Lwt.return_none) let parents_of_commit t hash = Log.debug (fun m -> m "Get parents of %a." Hash.pp hash); @@ -111,7 +111,7 @@ struct | Value.Commit commit -> ( Store.is_shallowed t hash >>= function | false -> Lwt.return (Store.Value.Commit.parents commit) - | true -> Lwt.return [] ) + | true -> Lwt.return []) | _ -> Lwt.return [] let parents ((t, _hashtbl) as store) hash = @@ -146,21 +146,20 @@ struct Store.unshallow t hash let access = - { - Sigs.get = - (fun uid t -> - Scheduler.inj (get_commit_for_negotiation (Ministore.prj t) uid)); - Sigs.parents = - (fun uid t -> Scheduler.inj (parents (Ministore.prj t) uid)); - Sigs.deref = - (fun t refname -> Scheduler.inj (deref (Ministore.prj t) refname)); - Sigs.locals = (fun t -> Scheduler.inj (locals (Ministore.prj t))); - Sigs.shallowed = (fun t -> Scheduler.inj (shallowed (Ministore.prj t))); - Sigs.shallow = - (fun t uid -> Scheduler.inj (shallow (Ministore.prj t) uid)); - Sigs.unshallow = - (fun t uid -> Scheduler.inj (unshallow (Ministore.prj t) uid)); - } + Sigs. + { + get = + (fun uid t -> + Scheduler.inj (get_commit_for_negotiation (Ministore.prj t) uid)); + parents = (fun uid t -> Scheduler.inj (parents (Ministore.prj t) uid)); + deref = + (fun t refname -> Scheduler.inj (deref (Ministore.prj t) refname)); + locals = (fun t -> Scheduler.inj (locals (Ministore.prj t))); + shallowed = (fun t -> Scheduler.inj (shallowed (Ministore.prj t))); + shallow = (fun t uid -> Scheduler.inj (shallow (Ministore.prj t) uid)); + unshallow = + (fun t uid -> Scheduler.inj (unshallow (Ministore.prj t) uid)); + } let lightly_load t hash = Store.read_exn t hash >>= fun v -> @@ -188,8 +187,9 @@ struct Lwt.return (Carton.Dec.v ~kind raw) | None -> Lwt.fail Not_found - include Smart_git.Make (Scheduler) (Pack) (Index) (Conduit) (HTTP) (Hash) - (Reference) + include + Smart_git.Make (Scheduler) (Pack) (Index) (Conduit) (HTTP) (Hash) + (Reference) let ( >>? ) x f = x >>= function Ok x -> f x | Error err -> Lwt.return_error err @@ -278,21 +278,22 @@ struct | Some o as v -> Hashtbl.replace hashtbl hash o; Lwt.return v - | None -> Lwt.return_none ) + | None -> Lwt.return_none) let access = - { - Sigs.get = - (fun uid t -> - Scheduler.inj (get_object_for_packer (Ministore.prj t) uid)); - Sigs.parents = (fun _ _ -> assert false); - Sigs.deref = - (fun t refname -> Scheduler.inj (deref (Ministore.prj t) refname)); - Sigs.locals = (fun _ -> assert false); - Sigs.shallowed = (fun _ -> assert false); - Sigs.shallow = (fun _ -> assert false); - Sigs.unshallow = (fun _ -> assert false); - } + Sigs. + { + get = + (fun uid t -> + Scheduler.inj (get_object_for_packer (Ministore.prj t) uid)); + parents = (fun _ _ -> assert false); + deref = + (fun t refname -> Scheduler.inj (deref (Ministore.prj t) refname)); + locals = (fun _ -> assert false); + shallowed = (fun _ -> assert false); + shallow = (fun _ -> assert false); + unshallow = (fun _ -> assert false); + } let push ~resolvers endpoint t ?version ?capabilities cmds = let ministore = Ministore.inj (t, Hashtbl.create 0x100) in diff --git a/src/git/sync.mli b/src/git/sync.mli index 2507423f4..ae8059b1f 100644 --- a/src/git/sync.mli +++ b/src/git/sync.mli @@ -30,7 +30,7 @@ module type S = sig ?push_stdout:(string -> unit) -> ?push_stderr:(string -> unit) -> resolvers:Conduit.resolvers -> - Smart_git.endpoint -> + Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> ?capabilities:Smart.Capability.t list -> @@ -40,7 +40,7 @@ module type S = sig val push : resolvers:Conduit.resolvers -> - Smart_git.endpoint -> + Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> ?capabilities:Smart.Capability.t list -> @@ -75,7 +75,7 @@ module Make ?push_stdout:(string -> unit) -> ?push_stderr:(string -> unit) -> resolvers:Conduit.resolvers -> - Smart_git.endpoint -> + Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> ?capabilities:Smart.Capability.t list -> @@ -101,7 +101,7 @@ module Make val push : resolvers:Conduit.resolvers -> - Smart_git.endpoint -> + Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> ?capabilities:Smart.Capability.t list -> diff --git a/src/git/traverse_bfs.ml b/src/git/traverse_bfs.ml index 9fc4f0c1d..6e3e79817 100644 --- a/src/git/traverse_bfs.ml +++ b/src/git/traverse_bfs.ml @@ -49,7 +49,7 @@ module Make (Store : STORE) = struct | [] -> ( match Queue.pop queue with | rest -> walk close [ rest ] queue acc - | exception Queue.Empty -> Lwt.return acc ) + | exception Queue.Empty -> Lwt.return acc) | hash :: rest -> ( if Store.Hash.Set.mem hash close then walk close rest queue acc else @@ -66,7 +66,7 @@ module Make (Store : STORE) = struct (fun x -> Queue.add x queue) (Store.Value.Commit.parents commit); f acc ~length:(Store.Value.Commit.length commit) hash value - >>= fun acc' -> walk close' rest' queue acc' ) + >>= fun acc' -> walk close' rest' queue acc') | Value.Tree tree as value -> let path = try Hashtbl.find names hash with Not_found -> path @@ -98,7 +98,7 @@ module Make (Store : STORE) = struct | Value.Tag tag as value -> Queue.add (Store.Value.Tag.obj tag) queue; f acc ~length:(Store.Value.Tag.length tag) hash value - >>= fun acc' -> walk close' rest queue acc' ) + >>= fun acc' -> walk close' rest queue acc') in walk Store.Hash.Set.empty [ hash ] (Queue.create ()) acc diff --git a/src/git/tree.ml b/src/git/tree.ml index 4273e32cf..24bc5861e 100644 --- a/src/git/tree.ml +++ b/src/git/tree.ml @@ -56,13 +56,13 @@ type 'hash entry = { perm : perm; name : string; node : 'hash } let pp_entry ~pp ppf { perm; name; node } = Fmt.pf ppf "{ @[perm = %s;@ name = %S;@ node = %a;@] }" - ( match perm with + (match perm with | `Normal -> "normal" | `Everybody -> "everybody" | `Exec -> "exec" | `Link -> "link" | `Dir -> "dir" - | `Commit -> "commit" ) + | `Commit -> "commit") name (Fmt.hvbox pp) node let equal_entry ~equal a b = @@ -109,8 +109,8 @@ let compare x y = !p < len_a && !p < len_b && - ( c := Char.compare a.[!p] b.[!p]; - !c = 0 ) + (c := Char.compare a.[!p] b.[!p]; + !c = 0) do incr p done; @@ -235,12 +235,12 @@ module Make (Hash : S.HASH) : S with type hash = Hash.t = struct let hash = hash <$> fixed Hash.digest_size in let name = while1 is_not_nl in entry - <$> ( perm + <$> (perm <* (Encore.Bij.char ' ' <$> any) <* commit <*> (name <* (Encore.Bij.char '\x00' <$> any) <* commit) <*> (hash <* commit) - <* commit ) + <* commit) let format = Encore.Syntax.rep0 entry end diff --git a/src/git/user.ml b/src/git/user.ml index f73537b2e..a9d0e2d45 100644 --- a/src/git/user.ml +++ b/src/git/user.ml @@ -83,11 +83,11 @@ let int64 = let format = let open Encore.Syntax in Encore.Bij.(compose obj4) user - <$> ( chop + <$> (chop <$> (while1 is_not_lt <* (Encore.Bij.char '<' <$> any)) <*> (while1 is_not_gt <* (Encore.Bij.string "> " <$> const "> ")) <*> (int64 <$> while1 is_digit <* (Encore.Bij.char ' ' <$> any)) - <*> date ) + <*> date) let length t = let string x = Int64.of_int (String.length x) in diff --git a/src/git/value.ml b/src/git/value.ml index abecfb9e5..3807b1b2f 100644 --- a/src/git/value.ml +++ b/src/git/value.ml @@ -173,10 +173,10 @@ module Make (Hash : S.HASH) : S with type hash = Hash.t = struct <*> t in Encore.Bij.(compose obj3) iso - <$> ( value "commit" commit' + <$> (value "commit" commit' <|> value "tree" tree <|> value "blob" blob - <|> value "tag" tag ) + <|> value "tag" tag) end let format = Syntax.format @@ -241,12 +241,12 @@ module Make (Hash : S.HASH) : S with type hash = Hash.t = struct | Error _ -> Log.err (fun m -> m "Object %s is bad: @[%S@]" - ( match kind with + (match kind with | `Tree -> "tree" | `Commit -> "commit" - | `Tag -> "tag" ) + | `Tag -> "tag") (Cstruct.to_string raw)); - Error (`Msg "Invalid Git object") ) + Error (`Msg "Invalid Git object")) let to_raw_without_header = function | Blob v -> Cstruct.to_string (Blob.to_cstruct v) @@ -304,7 +304,7 @@ module Make (Hash : S.HASH) : S with type hash = Hash.t = struct if !consumed then Lwt.return_none else ( consumed := true; - Lwt.return_some (Cstruct.to_string (Blob.to_cstruct v)) ) + Lwt.return_some (Cstruct.to_string (Blob.to_cstruct v))) in stream | v -> diff --git a/src/loose/loose.ml b/src/loose/loose.ml index 26e26555a..f908877f9 100644 --- a/src/loose/loose.ml +++ b/src/loose/loose.ml @@ -112,13 +112,13 @@ module Make (Uid : UID) = struct ~len:max; let ctx = Uid.feed ctx buffers.i ~off:0 ~len:max in let encoder = Zl.Def.src encoder buffers.i 0 max in - go ctx (src, off + max, len - max) dsts encoder ) + go ctx (src, off + max, len - max) dsts encoder) else stream () >>= function | Some src -> go ctx (src, 0, String.length src) dsts encoder | None -> let encoder = Zl.Def.src encoder Bigstringaf.empty 0 0 in - go ctx payload dsts encoder ) + go ctx payload dsts encoder) | `Flush encoder -> let len = Bigstringaf.length buffers.o - Zl.Def.dst_rem encoder in let raw = Bigstringaf.copy buffers.o ~off:0 ~len in diff --git a/src/loose/loose_git.ml b/src/loose/loose_git.ml index ddd991b79..94eee10ab 100644 --- a/src/loose/loose_git.ml +++ b/src/loose/loose_git.ml @@ -105,7 +105,7 @@ struct | v -> Fmt.failwith "Invalid type of Git object: %s" v in contents, kind, length - | None -> failwith "Invalid Git header" ) + | None -> failwith "Invalid Git header") let hdr_set ~buffer (kind, length) = let kind = diff --git a/src/loose/loose_git_unix.ml b/src/loose/loose_git_unix.ml index 4c62ea429..13f74203e 100644 --- a/src/loose/loose_git_unix.ml +++ b/src/loose/loose_git_unix.ml @@ -111,7 +111,7 @@ module Make (Uid : UID) = struct | Error (`Msg _) -> failwithf "Directory contents %a: cannot parse element to a path (%S)" - Fpath.pp dir f ) + Fpath.pp dir f) | Some _ -> readdir dh acc in Lwt.catch @@ -212,7 +212,7 @@ module Make (Uid : UID) = struct | tl :: hd :: _ -> ( match Uid.of_hex (hd ^ tl) with | _ -> file_exists path - | exception _ -> Lwt.return_false ) + | exception _ -> Lwt.return_false) | _ -> Lwt.return_false (* fold *) @@ -274,7 +274,7 @@ module Make (Uid : UID) = struct | v -> Fmt.failwith "Invalid type of Git object: %s" v in contents, kind, length - | None -> failwith "Invalid Git header" ) + | None -> failwith "Invalid Git header") let hdr_set ~buffer (kind, length) = let kind = diff --git a/src/not-so-smart/capability.ml b/src/not-so-smart/capability.ml index 562261375..ad72df605 100644 --- a/src/not-so-smart/capability.ml +++ b/src/not-so-smart/capability.ml @@ -77,19 +77,19 @@ let of_string ?value = function | "push-cert" -> ( match value with | Some value -> `Push_cert value - | None -> raise (Capability_expect_value "push-cert") ) + | None -> raise (Capability_expect_value "push-cert")) | "agent" -> ( match value with | Some value -> `Agent value - | None -> raise (Capability_expect_value "agent") ) + | None -> raise (Capability_expect_value "agent")) | "symref" -> ( match Option.bind value (Astring.String.cut ~sep:":") with | Some (ref0, ref1) -> `Symref (ref0, ref1) - | None -> raise (Capability_expect_value "symref") ) + | None -> raise (Capability_expect_value "symref")) | capability -> ( match value with | Some value -> `Parameter (capability, value) - | None -> `Other capability ) + | None -> `Other capability) let pp ppf = function | `Multi_ack -> Fmt.pf ppf "Multi-ACK" diff --git a/src/not-so-smart/decoder.ml b/src/not-so-smart/decoder.ml index 30260d87d..763cc2261 100644 --- a/src/not-so-smart/decoder.ml +++ b/src/not-so-smart/decoder.ml @@ -120,8 +120,8 @@ let at_least_one_line decoder = while !pos < end_of_input decoder && - ( chr := Bytes.unsafe_get decoder.buffer !pos; - not (!chr = '\n' && !has_cr) ) + (chr := Bytes.unsafe_get decoder.buffer !pos; + not (!chr = '\n' && !has_cr)) do has_cr := !chr = '\r'; incr pos @@ -230,7 +230,7 @@ let prompt : if strict then fun () -> fail decoder `End_of_input else ( decoder.max <- off; - reliable_pkt k decoder ) + reliable_pkt k decoder) in Read { @@ -242,7 +242,7 @@ let prompt : } else ( decoder.max <- off; - safe k decoder ) + safe k decoder) with | _exn (* XXX(dinosaure): [at_least_one_pkt] can raise an exception. *) -> fail decoder `Invalid_pkt_line @@ -267,8 +267,8 @@ let peek_while_eol decoder = while !idx < end_of_input decoder && - ( chr := Bytes.unsafe_get decoder.buffer !idx; - not (!chr = '\n' && !has_cr) ) + (chr := Bytes.unsafe_get decoder.buffer !idx; + not (!chr = '\n' && !has_cr)) do has_cr := !chr = '\r'; incr idx @@ -276,7 +276,7 @@ let peek_while_eol decoder = if !idx < end_of_input decoder && !chr = '\n' && !has_cr then ( assert (!idx + 1 - decoder.pos > 1); - decoder.buffer, decoder.pos, !idx + 1 - decoder.pos ) + decoder.buffer, decoder.pos, !idx + 1 - decoder.pos) else leave_with decoder `Expected_eol let peek_while_eol_or_space decoder = @@ -287,8 +287,8 @@ let peek_while_eol_or_space decoder = while !idx < end_of_input decoder && - ( chr := Bytes.unsafe_get decoder.buffer !idx; - (not (!chr = '\n' && !has_cr)) && !chr <> ' ' ) + (chr := Bytes.unsafe_get decoder.buffer !idx; + (not (!chr = '\n' && !has_cr)) && !chr <> ' ') do has_cr := !chr = '\r'; incr idx diff --git a/src/not-so-smart/default.ml b/src/not-so-smart/default.ml index e2303660f..de8bcb8e2 100644 --- a/src/not-so-smart/default.ml +++ b/src/not-so-smart/default.ml @@ -66,7 +66,7 @@ let rec mark_common : if only_ancestors then p := !p lor _common; if !p land _seen = 0 then ( rev_list_push t (uid, p, ts) _seen; - return () ) + return ()) else ( if (not only_ancestors) && !p land _popped = 0 then state.non_common_revs <- non_common_revs - 1; @@ -78,7 +78,7 @@ let rec mark_common : mark_common scheduler ~parents store t (uid, p, ts) false >>= fun () -> go rest in - go ) + go) let known_common : type g s uid. @@ -91,7 +91,7 @@ let known_common : fun ({ return; _ } as scheduler) ~parents store t (uid, p, ts) -> if !p land _seen = 0 then ( rev_list_push t (uid, p, ts) (_common_ref lor _seen); - mark_common scheduler ~parents store t (uid, p, ts) true ) + mark_common scheduler ~parents store t (uid, p, ts) true) else return () let tip t obj = rev_list_push t obj _seen @@ -139,13 +139,12 @@ let get_rev : if !p land _common <> 0 then ( mark := _common lor _seen; - res := None ) + res := None) else if !p land _common_ref <> 0 then mark := _common lor _seen else mark := _seen; let rec loop = function - | [] -> ( - match !res with None -> go () | Some _ as v -> return v ) + | [] -> ( match !res with None -> go () | Some _ as v -> return v) | (uid, p, ts) :: rest -> if !p land _seen = 0 then rev_list_push t (uid, p, ts) !mark; diff --git a/src/not-so-smart/dune b/src/not-so-smart/dune index 250b5a0d0..ae4babde0 100644 --- a/src/not-so-smart/dune +++ b/src/not-so-smart/dune @@ -17,6 +17,12 @@ (modules sigs) (libraries fmt cstruct)) +(library + (name hkt) + (public_name git-nss.hkt) + (modules hkt) + (libraries git-nss.sigs)) + (library (name neg) (public_name git-nss.neg) diff --git a/src/not-so-smart/encoder.ml b/src/not-so-smart/encoder.ml index 0a8d1a64a..a68f5efb3 100644 --- a/src/not-so-smart/encoder.ml +++ b/src/not-so-smart/encoder.ml @@ -37,7 +37,7 @@ let flush k0 encoder = } else ( encoder.pos <- 0; - k0 encoder ) + k0 encoder) in k1 0 else k0 encoder diff --git a/src/not-so-smart/fetch.ml b/src/not-so-smart/fetch.ml index d79564a9a..1089c0e38 100644 --- a/src/not-so-smart/fetch.ml +++ b/src/not-so-smart/fetch.ml @@ -1,5 +1,3 @@ -open Sigs - type configuration = Neg.configuration let multi_ack capabilities = @@ -20,12 +18,14 @@ let configuration ?(stateless = false) capabilities = Neg.multi_ack = multi_ack capabilities; } +module S = Sigs + module Make - (Scheduler : SCHED) - (IO : IO with type 'a t = 'a Scheduler.s) - (Flow : FLOW with type 'a fiber = 'a Scheduler.s) - (Uid : UID) - (Ref : REF) = + (Scheduler : S.SCHED) + (IO : S.IO with type 'a t = 'a Scheduler.s) + (Flow : S.FLOW with type 'a fiber = 'a Scheduler.s) + (Uid : S.UID) + (Ref : S.REF) = struct open Scheduler @@ -37,7 +37,7 @@ struct let return x = IO.return x let sched = - Sigs. + S. { bind = (fun x f -> inj (prj x >>= fun x -> prj (f x))); return = (fun x -> inj (return x)); @@ -48,7 +48,7 @@ struct inj fail let io = - Sigs. + S. { recv = (fun flow raw -> inj (Flow.recv flow raw)); send = (fun flow raw -> inj (Flow.send flow raw)); @@ -60,7 +60,9 @@ struct | `None -> [], [] | `All -> List.fold_left - (fun acc -> function uid, ref, false -> (uid, ref) :: acc | _ -> acc) + (fun acc -> function + | uid, ref, false -> (uid, ref) :: acc + | _ -> acc) [] have |> List.split | `Some refs -> @@ -92,10 +94,10 @@ struct let* v = recv ctx advertised_refs in let v = Smart.Advertised_refs.map ~fuid:Uid.of_hex ~fref:Ref.v v in let uids, refs = references refs (Smart.Advertised_refs.refs v) in - update ctx (Smart.Advertised_refs.capabilities v); + Smart.Context.update ctx (Smart.Advertised_refs.capabilities v); return (uids, refs) in - let ctx = Smart.make capabilities in + let ctx = Smart.Context.make capabilities in let negotiator = Neg.make ~compare:Uid.compare in Neg.tips sched access store negotiator |> prj >>= fun () -> Neg.run sched fail io flow (prelude ctx) |> prj >>= fun (uids, refs) -> @@ -111,7 +113,8 @@ struct let pack ctx = let open Smart in let side_band = - Smart.shared `Side_band ctx || Smart.shared `Side_band_64k ctx + Smart.Context.is_cap_shared `Side_band ctx + || Smart.Context.is_cap_shared `Side_band_64k ctx in recv ctx (recv_pack ~side_band ~push_stdout ~push_stderr ~push_pack:pack) diff --git a/src/not-so-smart/find_common.ml b/src/not-so-smart/find_common.ml index c91717fc9..024994902 100644 --- a/src/not-so-smart/find_common.ml +++ b/src/not-so-smart/find_common.ml @@ -41,7 +41,7 @@ let run : go (k len) | Error err -> Log.err (fun m -> m "Got an error: %a." pp_error err); - failwithf "%a" pp_error err ) + failwithf "%a" pp_error err) | Smart.Write { k; buffer; off; len } -> let rec loop tmp = if Cstruct.len tmp = 0 then go (k len) @@ -156,18 +156,17 @@ let find_common ({ bind; return } as scheduler) io flow Smart.( let uid = (to_hex <.> fst) uid in let others = List.map (to_hex <.> fst) others in - let capabilities, _ = Smart.capabilities ctx in + let capabilities, _ = Smart.Context.capabilities ctx in let deepen = - ( deepen - :> [ `Depth of int | `Not of string | `Timestamp of int64 ] option - ) + (deepen + :> [ `Depth of int | `Not of string | `Timestamp of int64 ] option) in send ctx want (Want.want ~capabilities ~shallows:shallowed ?deepen uid ~others)) >>= fun () -> - ( match deepen with + (match deepen with | None -> return () - | Some _ -> handle_shallow scheduler io flow hex access store ctx ) + | Some _ -> handle_shallow scheduler io flow hex access store ctx) >>= fun () -> let in_vain = ref 0 in let count = ref 0 in @@ -239,7 +238,7 @@ let find_common ({ bind; return } as scheduler) io flow in_vain := 0; retval := 0; got_continue := true; - loop () ) + loop ()) else if (not stateless) || not (Smart.Negotiation.is_common ack) @@ -249,13 +248,13 @@ let find_common ({ bind; return } as scheduler) io flow got_continue := true; if Smart.Negotiation.is_ready ack then got_ready := true; - loop () ) + loop ()) else ( retval := 0; got_continue := true; if Smart.Negotiation.is_ready ack then got_ready := true; - loop () ) ) + loop ())) in loop () >>= function | `Done -> return () @@ -263,24 +262,24 @@ let find_common ({ bind; return } as scheduler) io flow decr flushes; if !got_continue && _max_in_vain < !in_vain then return () else if !got_ready then return () - else go negotiator ) + else go negotiator) else go negotiator in go negotiator >>= fun () -> Log.debug (fun m -> m "Negotiation (got ready: %b, no-done: %b)." !got_ready no_done); - ( if (not !got_ready) || not no_done then - run scheduler raise io flow Smart.(send ctx negotiation_done ()) - else return () ) + (if (not !got_ready) || not no_done then + run scheduler raise io flow Smart.(send ctx negotiation_done ()) + else return ()) >>= fun () -> if !retval <> 0 then ( cfg.multi_ack <- `None; - incr flushes ); - ( if (not !got_ready) || not no_done then ( - Log.debug (fun m -> m "Negotiation is done!"); - run scheduler raise io flow Smart.(recv ctx shallows) - >>= fun _shallows -> return () ) - else return () ) + incr flushes); + (if (not !got_ready) || not no_done then ( + Log.debug (fun m -> m "Negotiation is done!"); + run scheduler raise io flow Smart.(recv ctx shallows) + >>= fun _shallows -> return ()) + else return ()) >>= fun () -> let rec go () = if !flushes > 0 || cfg.multi_ack = `Some || cfg.multi_ack = `Detailed @@ -296,7 +295,7 @@ let find_common ({ bind; return } as scheduler) io flow go () | Smart.Negotiation.NAK -> decr flushes; - go () ) + go ()) else if !count > 0 then return (`Continue !retval) else return (`Continue 0) in diff --git a/src/not-so-smart/hkt.ml b/src/not-so-smart/hkt.ml new file mode 100644 index 000000000..ad418f5c6 --- /dev/null +++ b/src/not-so-smart/hkt.ml @@ -0,0 +1,28 @@ +(** This is a module used to share functionality needed by modules that + contain higher-kinded type behavior. + + HKT = Higher-Kinded Types *) +module HKT = struct + type t + + external inj : 'a -> 'b = "%identity" + external prj : 'a -> 'b = "%identity" +end + +module Make_sched (T : sig + type +'a t +end) = +struct + type +'a s = 'a T.t + + include HKT +end + +module Make_store (T : sig + type ('k, 'v) t +end) = +struct + type ('a, 'b) s = ('a, 'b) T.t + + include HKT +end diff --git a/src/not-so-smart/hkt.mli b/src/not-so-smart/hkt.mli new file mode 100644 index 000000000..68eef2973 --- /dev/null +++ b/src/not-so-smart/hkt.mli @@ -0,0 +1,7 @@ +module Make_sched (T : sig + type +'a t +end) : Sigs.SCHED with type +'a s = 'a T.t + +module Make_store (T : sig + type ('k, 'v) t +end) : Sigs.STORE with type ('k, 'v) s = ('k, 'v) T.t diff --git a/src/not-so-smart/neg.mli b/src/not-so-smart/neg.mli index 362122158..2691a53ac 100644 --- a/src/not-so-smart/neg.mli +++ b/src/not-so-smart/neg.mli @@ -53,7 +53,7 @@ val find_common : ('uid, 'ref, 'uid * int ref * int64, 'g, 's) access -> ('uid, 'uid * int ref * int64, 'g) store -> 'uid negotiator -> - Smart.context -> + Smart.Context.t -> ?deepen:[ `Depth of int | `Timestamp of int64 ] -> 'uid list -> ([ `Continue of int | `Close ], 's) io diff --git a/src/not-so-smart/pck.ml b/src/not-so-smart/pck.ml index 16f839023..a0586700f 100644 --- a/src/not-so-smart/pck.ml +++ b/src/not-so-smart/pck.ml @@ -67,7 +67,7 @@ let commands { bind; return } ~capabilities ~equal:equal_reference ~deref store | `Create reference -> ( deref store reference >>= function | Some uid -> return (Smart.Commands.create uid reference :: acc) - | None -> return acc ) + | None -> return acc) | `Delete reference -> let uid, _, _ = List.find @@ -86,7 +86,7 @@ let commands { bind; return } ~capabilities ~equal:equal_reference ~deref store equal_reference remote reference' && peeled = false) have in - return (Smart.Commands.update uid_old uid_new remote :: acc) ) + return (Smart.Commands.update uid_old uid_new remote :: acc)) in let rec go a = function | [] -> return a @@ -189,7 +189,7 @@ let get_uncommon_objects : value.color <- color; List.iter (fun uid -> Queue.push uid q) (preds node); go () - | None | (exception Not_found) -> go () ) + | None | (exception Not_found) -> go ()) | exception Queue.Empty -> () in List.iter (fun uid -> Queue.push uid q) (preds node); diff --git a/src/not-so-smart/protocol.ml b/src/not-so-smart/protocol.ml index dfd14194f..13c2c0d82 100644 --- a/src/not-so-smart/protocol.ml +++ b/src/not-so-smart/protocol.ml @@ -325,7 +325,7 @@ module Decoder = struct let v = peek_pkt decoder in if String.Sub.is_empty v then ( junk_pkt decoder; - return { advertised_refs with Advertised_refs.shallows } decoder ) + return { advertised_refs with Advertised_refs.shallows } decoder) else match String.Sub.cut ~sep:v_space v with | Some (_, uid) -> @@ -350,7 +350,7 @@ module Decoder = struct version; shallows = []; } - decoder ) + decoder) else if String.Sub.is_prefix ~affix:v_shallow v then decode_shallows { @@ -482,7 +482,7 @@ module Decoder = struct let v = peek_pkt decoder in if String.Sub.equal_bytes v v_nak then ( junk_pkt decoder; - return Result.NAK decoder ) + return Result.NAK decoder) else match String.Sub.cut ~sep:v_space v with | Some (_, common) -> @@ -508,7 +508,7 @@ module Decoder = struct let rest = decoder.max - decoder.pos in Bytes.unsafe_blit decoder.buffer decoder.pos decoder.buffer 0 rest; decoder.max <- rest; - decoder.pos <- 0 ); + decoder.pos <- 0); let rec go off = if off = Bytes.length decoder.buffer && decoder.pos > 0 then Error @@ -519,7 +519,7 @@ module Decoder = struct } else if off - decoder.pos > 0 then ( decoder.max <- off; - safe kcontinue decoder ) + safe kcontinue decoder) else Read { @@ -581,7 +581,7 @@ module Decoder = struct let v = peek_pkt decoder in if String.Sub.length v = 0 then ( junk_pkt decoder; - return (List.rev acc) decoder ) + return (List.rev acc) decoder) else if String.Sub.is_prefix ~affix:v_shallow v || String.Sub.is_prefix ~affix:v_unshallow v @@ -591,10 +591,10 @@ module Decoder = struct let uid = String.Sub.to_string uid in if String.Sub.equal_bytes v v_shallow then ( junk_pkt decoder; - prompt_pkt (go (Shallow.Shallow uid :: acc)) decoder ) + prompt_pkt (go (Shallow.Shallow uid :: acc)) decoder) else ( junk_pkt decoder; - prompt_pkt (go (Shallow.Unshallow uid :: acc)) decoder ) + prompt_pkt (go (Shallow.Unshallow uid :: acc)) decoder) | _ -> return (List.rev acc) decoder else return (List.rev acc) decoder in @@ -605,7 +605,7 @@ module Decoder = struct let pkt = peek_pkt decoder in if String.Sub.equal_bytes pkt v_nak then ( junk_pkt decoder; - return Negotiation.NAK decoder ) + return Negotiation.NAK decoder) else if String.Sub.is_prefix ~affix:v_ack pkt then match String.Sub.cuts ~sep:v_space pkt with | [ _; uid ] -> @@ -622,7 +622,7 @@ module Decoder = struct | "continue" -> return (Negotiation.ACK_continue uid) decoder | "ready" -> return (Negotiation.ACK_ready uid) decoder | "common" -> return (Negotiation.ACK_common uid) decoder - | _ -> fail decoder (`Invalid_ack (String.Sub.to_string pkt)) ) + | _ -> fail decoder (`Invalid_ack (String.Sub.to_string pkt))) | _ -> fail decoder (`Invalid_ack (String.Sub.to_string pkt)) else assert false in @@ -650,8 +650,7 @@ module Decoder = struct let reference = String.Sub.to_string reference in Stdlib.Ok (Stdlib.Error (reference, err)) | _ -> - Stdlib.Error (`Invalid_command_result (String.Sub.to_string pkt)) - ) + Stdlib.Error (`Invalid_command_result (String.Sub.to_string pkt))) | _ -> Stdlib.Error (`Invalid_command_result (String.Sub.to_string pkt)) in @@ -684,7 +683,7 @@ module Decoder = struct return (Stdlib.Ok ()) decoder | err -> junk_pkt decoder; - return (Stdlib.Error err) decoder ) + return (Stdlib.Error err) decoder) in prompt_pkt result decoder >>= fun result -> prompt_pkt commands decoder >>= fun commands -> @@ -764,7 +763,7 @@ module Encoder = struct if version > 1 then ( write_zero encoder; write_version encoder version; - write_zero encoder ) + write_zero encoder) in delayed_write_pkt k kdone encoder @@ -842,7 +841,7 @@ module Encoder = struct in if List.length capabilities > 0 then ( write_space encoder; - go capabilities ); + go capabilities); write_new_line encoder in diff --git a/src/not-so-smart/push.ml b/src/not-so-smart/push.ml index 5bdccc883..3992dc1b6 100644 --- a/src/not-so-smart/push.ml +++ b/src/not-so-smart/push.ml @@ -1,16 +1,17 @@ open Rresult -open Sigs type configuration = { stateless : bool } let configuration ?(stateless = true) () = { stateless } +module S = Sigs + module Make - (Scheduler : SCHED) - (IO : IO with type 'a t = 'a Scheduler.s) - (Flow : FLOW with type 'a fiber = 'a Scheduler.s) - (Uid : UID) - (Ref : REF) = + (Scheduler : S.SCHED) + (IO : S.IO with type 'a t = 'a Scheduler.s) + (Flow : S.FLOW with type 'a fiber = 'a Scheduler.s) + (Uid : S.UID) + (Ref : S.REF) = struct let src = Logs.Src.create "push" @@ -22,19 +23,21 @@ struct let ( >>| ) x f = x >>= fun x -> return (f x) let sched = - { - Sigs.bind = (fun x f -> inj (prj x >>= fun x -> prj (f x))); - Sigs.return = (fun x -> inj (return x)); - } + S. + { + bind = (fun x f -> inj (prj x >>= fun x -> prj (f x))); + return = (fun x -> inj (return x)); + } let fail exn = inj (IO.fail exn) let io = - { - Sigs.recv = (fun flow raw -> inj (Flow.recv flow raw)); - Sigs.send = (fun flow raw -> inj (Flow.send flow raw)); - Sigs.pp_error = Flow.pp_error; - } + S. + { + recv = (fun flow raw -> inj (Flow.recv flow raw)); + send = (fun flow raw -> inj (Flow.send flow raw)); + pp_error = Flow.pp_error; + } let push ?(prelude = true) ~capabilities:caps cmds ~host path flow store access push_cfg pack = @@ -47,10 +50,10 @@ struct else return () in let* v = recv ctx advertised_refs in - update ctx (Smart.Advertised_refs.capabilities v); + Context.update ctx (Smart.Advertised_refs.capabilities v); return (Smart.Advertised_refs.map ~fuid:Uid.of_hex ~fref:Ref.v v) in - let ctx = Smart.make caps in + let ctx = Smart.Context.make caps in Neg.run sched fail io flow (fiber ctx) |> prj >>= fun advertised_refs -> Pck.commands sched ~capabilities:(Smart.Advertised_refs.capabilities advertised_refs) @@ -81,13 +84,16 @@ struct m "Prepare a pack of %d object(s)." (List.length uids)); let stream = pack uids in let side_band = - Smart.shared `Side_band ctx || Smart.shared `Side_band_64k ctx + Smart.Context.is_cap_shared `Side_band ctx + || Smart.Context.is_cap_shared `Side_band_64k ctx in let pack = Smart.send_pack ~stateless:push_cfg.stateless side_band in let rec go () = stream () >>= function | None -> - let report_status = Smart.shared `Report_status ctx in + let report_status = + Smart.Context.is_cap_shared `Report_status ctx + in Log.debug (fun m -> m "report-status capability: %b." report_status); if report_status then @@ -111,5 +117,5 @@ struct return () | Error err -> Log.err (fun m -> m "Push got an error: %s" err); - return () ) + return ()) end diff --git a/src/not-so-smart/sigs.ml b/src/not-so-smart/sigs.ml index 797e34003..708ce8026 100644 --- a/src/not-so-smart/sigs.ml +++ b/src/not-so-smart/sigs.ml @@ -41,38 +41,6 @@ module type STORE = sig external prj : ('a, 'b, t) store -> ('a, 'b) s = "%identity" end -module Common_sched = struct - type t - - external inj : 'a -> 'b = "%identity" - external prj : 'a -> 'b = "%identity" -end - -module Common_store = struct - type t - - external inj : 'a -> 'b = "%identity" - external prj : 'a -> 'b = "%identity" -end - -module Make_sched (T : sig - type +'a t -end) = -struct - type +'a s = 'a T.t - - include Common_sched -end - -module Make_store (T : sig - type ('k, 'v) t -end) = -struct - type ('a, 'b) s = ('a, 'b) T.t - - include Common_store -end - module type IO = sig type +'a t diff --git a/src/not-so-smart/sigs.mli b/src/not-so-smart/sigs.mli deleted file mode 100644 index 433c44e94..000000000 --- a/src/not-so-smart/sigs.mli +++ /dev/null @@ -1,87 +0,0 @@ -type ('a, 's) io -type ('k, 'v, 's) store - -type 's scheduler = { - bind : 'a 'b. ('a, 's) io -> ('a -> ('b, 's) io) -> ('b, 's) io; - return : 'a. 'a -> ('a, 's) io; -} - -type ('flow, 'error, 's) flow = { - recv : - 'flow -> - Cstruct.t -> - (([ `End_of_flow | `Input of int ], 'error) result, 's) io; - send : 'flow -> Cstruct.t -> ((int, 'error) result, 's) io; - pp_error : Format.formatter -> 'error -> unit; -} - -type ('uid, 'ref, 'v, 'g, 's) access = { - get : 'uid -> ('uid, 'v, 'g) store -> ('v option, 's) io; - parents : 'uid -> ('uid, 'v, 'g) store -> ('v list, 's) io; - deref : ('uid, 'v, 'g) store -> 'ref -> ('uid option, 's) io; - locals : ('uid, 'v, 'g) store -> ('ref list, 's) io; - shallowed : ('uid, 'v, 'g) store -> ('uid list, 's) io; - shallow : ('uid, 'v, 'g) store -> 'uid -> (unit, 's) io; - unshallow : ('uid, 'v, 'g) store -> 'uid -> (unit, 's) io; -} - -module type SCHED = sig - type +'a s - type t - - external inj : 'a s -> ('a, t) io = "%identity" - external prj : ('a, t) io -> 'a s = "%identity" -end - -module type STORE = sig - type ('a, 'b) s - type t - - external inj : ('a, 'b) s -> ('a, 'b, t) store = "%identity" - external prj : ('a, 'b, t) store -> ('a, 'b) s = "%identity" -end - -module Make_sched (T : sig - type +'a t -end) : SCHED with type +'a s = 'a T.t - -module Make_store (T : sig - type ('k, 'v) t -end) : STORE with type ('k, 'v) s = ('k, 'v) T.t - -module type IO = sig - type +'a t - - val bind : 'a t -> ('a -> 'b t) -> 'b t - val return : 'a -> 'a t - val fail : exn -> 'a t - val async : (unit -> unit t) -> unit -end - -module type UID = sig - type t - - val of_hex : string -> t - val to_hex : t -> string - val compare : t -> t -> int -end - -module type REF = sig - type t - - val v : string -> t - val equal : t -> t -> bool - val to_string : t -> string -end - -module type FLOW = sig - type +'a fiber - type t - type error - - val recv : - t -> Cstruct.t -> ([ `End_of_flow | `Input of int ], error) result fiber - - val send : t -> Cstruct.t -> (int, error) result fiber - val pp_error : error Fmt.t -end diff --git a/src/not-so-smart/smart.ml b/src/not-so-smart/smart.ml index 819222e7b..cd595c9fd 100644 --- a/src/not-so-smart/smart.ml +++ b/src/not-so-smart/smart.ml @@ -1,14 +1,18 @@ let ( <.> ) f g x = f (g x) module Capability = Capability -module Proto_request = Protocol.Proto_request -module Advertised_refs = Protocol.Advertised_refs -module Want = Protocol.Want -module Result = Protocol.Result -module Negotiation = Protocol.Negotiation -module Shallow = Protocol.Shallow -module Commands = Protocol.Commands -module Status = Protocol.Status + +include struct + open Protocol + module Proto_request = Proto_request + module Advertised_refs = Advertised_refs + module Want = Want + module Result = Result + module Negotiation = Negotiation + module Shallow = Shallow + module Commands = Commands + module Status = Status +end module Witness = struct type 'a send = @@ -49,21 +53,23 @@ module Value = struct let encode : type a. encoder -> a send -> a -> (unit, [> Encoder.error ]) State.t = fun encoder w v -> - let fiber : a send -> [> Encoder.error ] Encoder.state = function - | Proto_request -> Protocol.Encoder.encode_proto_request encoder v - | Want -> Protocol.Encoder.encode_want encoder v - | Done -> Protocol.Encoder.encode_done encoder - | Commands -> Protocol.Encoder.encode_commands encoder v + let fiber : a send -> [> Encoder.error ] Encoder.state = + let open Protocol.Encoder in + function + | Proto_request -> encode_proto_request encoder v + | Want -> encode_want encoder v + | Done -> encode_done encoder + | Commands -> encode_commands encoder v | Send_pack { side_band; stateless } -> - Protocol.Encoder.encode_pack ~side_band ~stateless encoder v - | Flush -> Protocol.Encoder.encode_flush encoder - | Advertised_refs -> Protocol.Encoder.encode_advertised_refs encoder v + encode_pack ~side_band ~stateless encoder v + | Flush -> encode_flush encoder + | Advertised_refs -> encode_advertised_refs encoder v in let rec go = function | Encoder.Done -> State.Return () - | Encoder.Write { continue; buffer; off; len } -> + | Write { continue; buffer; off; len } -> State.Write { k = go <.> continue; buffer; off; len } - | Encoder.Error err -> State.Error (err :> error) + | Error err -> State.Error (err :> error) in (go <.> fiber) w @@ -71,21 +77,20 @@ module Value = struct fun decoder w -> let rec go = function | Decoder.Done v -> State.Return v - | Decoder.Read { buffer; off; len; continue; eof } -> + | Read { buffer; off; len; continue; eof } -> State.Read { k = go <.> continue; buffer; off; len; eof = go <.> eof } - | Decoder.Error { error; _ } -> State.Error error + | Error { error; _ } -> State.Error error in + let open Protocol.Decoder in match w with - | Advertised_refs -> go (Protocol.Decoder.decode_advertised_refs decoder) - | Result -> go (Protocol.Decoder.decode_result decoder) + | Advertised_refs -> go (decode_advertised_refs decoder) + | Result -> go (decode_result decoder) | Recv_pack { side_band; push_pack; push_stdout; push_stderr } -> - go - (Protocol.Decoder.decode_pack ~side_band ~push_pack ~push_stdout - ~push_stderr decoder) - | Ack -> go (Protocol.Decoder.decode_negotiation decoder) - | Status -> go (Protocol.Decoder.decode_status decoder) - | Shallows -> go (Protocol.Decoder.decode_shallows decoder) - | Packet trim -> go (Protocol.Decoder.decode_packet ~trim decoder) + go (decode_pack ~side_band ~push_pack ~push_stdout ~push_stderr decoder) + | Ack -> go (decode_negotiation decoder) + | Status -> go (decode_status decoder) + | Shallows -> go (decode_shallows decoder) + | Packet trim -> go (decode_packet ~trim decoder) end type ('a, 'err) t = ('a, 'err) State.t = @@ -100,12 +105,14 @@ type ('a, 'err) t = ('a, 'err) State.t = | Return of 'a | Error of 'err -type context = State.Context.t +module Context = struct + type t = State.Context.t -let make capabilities = State.Context.make capabilities -let update ctx capabilities = State.Context.update ctx capabilities -let shared ctx capability = State.Context.shared ctx capability -let capabilities ctx = State.Context.capabilities ctx + let make = State.Context.make + let update = State.Context.update + let is_cap_shared = State.Context.is_cap_shared + let capabilities = State.Context.capabilities +end include Witness diff --git a/src/not-so-smart/smart.mli b/src/not-so-smart/smart.mli index 2ac0accca..1245404f5 100644 --- a/src/not-so-smart/smart.mli +++ b/src/not-so-smart/smart.mli @@ -183,12 +183,14 @@ type error = val pp_error : error Fmt.t -type context +module Context : sig + type t -val make : Capability.t list -> context -val update : context -> Capability.t list -> unit -val shared : Capability.t -> context -> bool -val capabilities : context -> Capability.t list * Capability.t list + val make : Capability.t list -> t + val update : t -> Capability.t list -> unit + val is_cap_shared : Capability.t -> t -> bool + val capabilities : t -> Capability.t list * Capability.t list +end type 'a send @@ -221,20 +223,20 @@ val ( let* ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t val ( >>= ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t val encode : - context -> + Context.t -> 'a send -> 'a -> - (context -> ('b, ([> `Protocol of error ] as 'err)) t) -> + (Context.t -> ('b, ([> `Protocol of error ] as 'err)) t) -> ('b, 'err) t val decode : - context -> + Context.t -> 'a recv -> - (context -> 'a -> ('b, ([> `Protocol of error ] as 'err)) t) -> + (Context.t -> 'a -> ('b, ([> `Protocol of error ] as 'err)) t) -> ('b, 'err) t -val send : context -> 'a send -> 'a -> (unit, [> `Protocol of error ]) t -val recv : context -> 'a recv -> ('a, [> `Protocol of error ]) t +val send : Context.t -> 'a send -> 'a -> (unit, [> `Protocol of error ]) t +val recv : Context.t -> 'a recv -> ('a, [> `Protocol of error ]) t val return : 'v -> ('v, 'err) t val fail : 'err -> ('v, 'err) t val reword_error : ('err0 -> 'err1) -> ('v, 'err0) t -> ('v, 'err1) t @@ -245,5 +247,5 @@ val error_msgf : (**/**) module Unsafe : sig - val write : context -> string -> unit + val write : Context.t -> string -> unit end diff --git a/src/not-so-smart/smart_git.ml b/src/not-so-smart/smart_git.ml index c6063e4d8..18950af3e 100644 --- a/src/not-so-smart/smart_git.ml +++ b/src/not-so-smart/smart_git.ml @@ -56,84 +56,88 @@ end let ( <.> ) f g x = f (g x) -type endpoint = { - scheme : - [ `SSH of string - | `Git - | `HTTP of (string * string) list - | `HTTPS of (string * string) list ]; - path : string; - endpoint : Conduit.Endpoint.t; -} - -let pp_endpoint ppf edn = - match edn with - | { scheme = `SSH user; path; endpoint } -> - Fmt.pf ppf "%s@%a:%s" user Conduit.Endpoint.pp endpoint path - | { scheme = `Git; path; endpoint } -> - Fmt.pf ppf "git://%a/%s" Conduit.Endpoint.pp endpoint path - | { scheme = `HTTP _; path; endpoint } -> - Fmt.pf ppf "http://%a/%s" Conduit.Endpoint.pp endpoint path - | { scheme = `HTTPS _; path; endpoint } -> - Fmt.pf ppf "https://%a/%s" Conduit.Endpoint.pp endpoint path - -let endpoint_of_string str = - let open Rresult in - let parse_ssh x = - let max = String.length x in - Emile.of_string_raw ~off:0 ~len:max x - |> R.reword_error (R.msgf "%a" Emile.pp_error) - >>= fun (consumed, m) -> - match - Astring.String.cut ~sep:":" (String.sub x consumed (max - consumed)) - with - | Some ("", path) -> - let user = - String.concat "." - (List.map - (function `Atom x -> x | `String x -> Fmt.str "%S" x) - m.Emile.local) - in - ( match fst m.Emile.domain with - | `Domain vs -> - Domain_name.of_strings vs - >>= Domain_name.host - >>| Conduit.Endpoint.domain - | `Literal v -> - Domain_name.of_string v - >>= Domain_name.host - >>| Conduit.Endpoint.domain - | `Addr (Emile.IPv4 ipv4) -> R.ok (Conduit.Endpoint.ip (Ipaddr.V4 ipv4)) - | `Addr (Emile.IPv6 ipv6) -> R.ok (Conduit.Endpoint.ip (Ipaddr.V6 ipv6)) - | `Addr (Emile.Ext (ext, _)) -> - R.error_msgf "Git does not handle domain extension %s." ext ) - >>= fun endpoint -> R.ok { scheme = `SSH user; path; endpoint } - | _ -> R.error_msg "invalid pattern" - in - let parse_uri x = - let uri = Uri.of_string x in - match Uri.scheme uri, Uri.host uri, Uri.path uri with - | Some "git", Some host, path -> - Conduit.Endpoint.of_string host >>= fun endpoint -> - R.ok { scheme = `Git; path; endpoint } - | Some "http", Some host, path -> - Conduit.Endpoint.of_string host >>= fun endpoint -> - R.ok { scheme = `HTTP []; path; endpoint } - | Some "https", Some host, path -> - Conduit.Endpoint.of_string host >>= fun endpoint -> - R.ok { scheme = `HTTPS []; path; endpoint } - | _ -> R.error_msgf "invalid uri: %a" Uri.pp uri - in - match parse_ssh str, parse_uri str with - | Ok edn, _ -> R.ok edn - | Error _, Ok edn -> R.ok edn - | Error _, Error _ -> R.error_msgf "Invalid endpoint: %s" str - -let endpoint_with_headers headers ({ scheme; _ } as edn) = - match scheme with - | `SSH _ | `Git -> edn - | `HTTP _ -> { edn with scheme = `HTTP headers } - | `HTTPS _ -> { edn with scheme = `HTTPS headers } +module Endpoint = struct + type t = { + scheme : + [ `SSH of string + | `Git + | `HTTP of (string * string) list + | `HTTPS of (string * string) list ]; + path : string; + endpoint : Conduit.Endpoint.t; + } + + let pp ppf edn = + match edn with + | { scheme = `SSH user; path; endpoint } -> + Fmt.pf ppf "%s@%a:%s" user Conduit.Endpoint.pp endpoint path + | { scheme = `Git; path; endpoint } -> + Fmt.pf ppf "git://%a/%s" Conduit.Endpoint.pp endpoint path + | { scheme = `HTTP _; path; endpoint } -> + Fmt.pf ppf "http://%a/%s" Conduit.Endpoint.pp endpoint path + | { scheme = `HTTPS _; path; endpoint } -> + Fmt.pf ppf "https://%a/%s" Conduit.Endpoint.pp endpoint path + + let of_string str = + let open Rresult in + let parse_ssh x = + let max = String.length x in + Emile.of_string_raw ~off:0 ~len:max x + |> R.reword_error (R.msgf "%a" Emile.pp_error) + >>= fun (consumed, m) -> + match + Astring.String.cut ~sep:":" (String.sub x consumed (max - consumed)) + with + | Some ("", path) -> + let user = + String.concat "." + (List.map + (function `Atom x -> x | `String x -> Fmt.str "%S" x) + m.Emile.local) + in + (match fst m.Emile.domain with + | `Domain vs -> + Domain_name.of_strings vs + >>= Domain_name.host + >>| Conduit.Endpoint.domain + | `Literal v -> + Domain_name.of_string v + >>= Domain_name.host + >>| Conduit.Endpoint.domain + | `Addr (Emile.IPv4 ipv4) -> + R.ok (Conduit.Endpoint.ip (Ipaddr.V4 ipv4)) + | `Addr (Emile.IPv6 ipv6) -> + R.ok (Conduit.Endpoint.ip (Ipaddr.V6 ipv6)) + | `Addr (Emile.Ext (ext, _)) -> + R.error_msgf "Git does not handle domain extension %s." ext) + >>= fun endpoint -> R.ok { scheme = `SSH user; path; endpoint } + | _ -> R.error_msg "invalid pattern" + in + let parse_uri x = + let uri = Uri.of_string x in + match Uri.scheme uri, Uri.host uri, Uri.path uri with + | Some "git", Some host, path -> + Conduit.Endpoint.of_string host >>= fun endpoint -> + R.ok { scheme = `Git; path; endpoint } + | Some "http", Some host, path -> + Conduit.Endpoint.of_string host >>= fun endpoint -> + R.ok { scheme = `HTTP []; path; endpoint } + | Some "https", Some host, path -> + Conduit.Endpoint.of_string host >>= fun endpoint -> + R.ok { scheme = `HTTPS []; path; endpoint } + | _ -> R.error_msgf "invalid uri: %a" Uri.pp uri + in + match parse_ssh str, parse_uri str with + | Ok edn, _ -> R.ok edn + | Error _, Ok edn -> R.ok edn + | Error _, Error _ -> R.error_msgf "Invalid endpoint: %s" str + + let with_headers_if_http headers ({ scheme; _ } as edn) = + match scheme with + | `SSH _ | `Git -> edn + | `HTTP _ -> { edn with scheme = `HTTP headers } + | `HTTPS _ -> { edn with scheme = `HTTPS headers } +end module Make (Scheduler : Sigs.SCHED with type +'a s = 'a Lwt.t) @@ -376,11 +380,11 @@ struct let rec recv t raw = if t.pos = String.length t.ic then ( let open Lwt.Infix in - ( HTTP.post ~resolvers:t.resolvers ~headers:t.headers t.uri t.oc - >|= Rresult.(R.reword_error (R.msgf "%a" HTTP.pp_error)) ) + (HTTP.post ~resolvers:t.resolvers ~headers:t.headers t.uri t.oc + >|= Rresult.(R.reword_error (R.msgf "%a" HTTP.pp_error))) >>? fun (_resp, contents) -> t.ic <- t.ic ^ contents; - recv t raw ) + recv t raw) else let len = min (String.length t.ic - t.pos) (Cstruct.len raw) in Cstruct.blit_from_string t.ic t.pos raw 0 len; @@ -432,7 +436,7 @@ struct ~idx = let open Rresult in let open Lwt.Infix in - let endpoint = edn.endpoint in + let endpoint = edn.Endpoint.endpoint in let path = edn.path in let stream, pusher = Lwt_stream.create () in let pusher = function @@ -473,8 +477,7 @@ struct match scheme with | `HTTP headers -> ( Uri.of_string - (Fmt.str "http://%a%s.git" Conduit.Endpoint.pp endpoint - path), + (Fmt.str "http://%a%s.git" Conduit.Endpoint.pp endpoint path), headers ) | `HTTPS headers -> ( Uri.of_string @@ -604,7 +607,7 @@ struct let push ~resolvers (access, light_load, heavy_load) store edn ?(version = `V1) ?(capabilities = default_capabilities) cmds = let open Rresult in - match version, edn.scheme with + match version, edn.Endpoint.scheme with | `V1, ((`Git | `SSH _) as scheme) -> let prelude = match scheme with `Git -> true | `SSH _ -> false in let endpoint = edn.endpoint in diff --git a/src/not-so-smart/smart_git.mli b/src/not-so-smart/smart_git.mli index 970009790..d5351c26f 100644 --- a/src/not-so-smart/smart_git.mli +++ b/src/not-so-smart/smart_git.mli @@ -47,19 +47,24 @@ module type HTTP = sig (unit * string, error) result Lwt.t end -type endpoint = private { - scheme : - [ `SSH of string - | `Git - | `HTTP of (string * string) list - | `HTTPS of (string * string) list ]; - path : string; - endpoint : Conduit.Endpoint.t; -} +module Endpoint : sig + type t = private { + scheme : + [ `SSH of string + | `Git + | `HTTP of (string * string) list + | `HTTPS of (string * string) list ]; + path : string; + endpoint : Conduit.Endpoint.t; + } -val pp_endpoint : endpoint Fmt.t -val endpoint_of_string : string -> (endpoint, [> `Msg of string ]) result -val endpoint_with_headers : (string * string) list -> endpoint -> endpoint + val pp : t Fmt.t + val of_string : string -> (t, [> `Msg of string ]) result + + val with_headers_if_http : (string * string) list -> t -> t + (** [with_headers_if_http hdrs edn] if endpoint [edn] is [`HTTP] or [`HTTPS] + adds [hdrs] to [edn] *) +end module Make (Scheduler : Sigs.SCHED with type +'a s = 'a Lwt.t) @@ -80,7 +85,7 @@ module Make * Uid.t Carton_lwt.Thin.light_load * Uid.t Carton_lwt.Thin.heavy_load -> (Uid.t, Uid.t * int ref * int64, 'g) Sigs.store -> - endpoint -> + Endpoint.t -> ?version:[> `V1 ] -> ?capabilities:Smart.Capability.t list -> ?deepen:[ `Depth of int | `Timestamp of int64 ] -> @@ -101,7 +106,7 @@ module Make * Uid.t Carton_lwt.Thin.light_load * Uid.t Carton_lwt.Thin.heavy_load -> (Uid.t, Uid.t Pck.t, 'g) Sigs.store -> - endpoint -> + Endpoint.t -> ?version:[> `V1 ] -> ?capabilities:Smart.Capability.t list -> [ `Create of Ref.t | `Delete of Ref.t | `Update of Ref.t * Ref.t ] list -> diff --git a/src/not-so-smart/state.ml b/src/not-so-smart/state.ml index d6240586d..534a353ef 100644 --- a/src/not-so-smart/state.ml +++ b/src/not-so-smart/state.ml @@ -20,7 +20,7 @@ module type CONTEXT = sig val pp : t Fmt.t val encoder : t -> encoder val decoder : t -> decoder - val shared : Capability.t -> t -> bool + val is_cap_shared : Capability.t -> t -> bool end module type S = sig @@ -62,7 +62,7 @@ module Context = struct let update ({ capabilities = client_side, _; _ } as t) server_side = t.capabilities <- client_side, server_side - let shared capability t = + let is_cap_shared capability t = let client_side, server_side = t.capabilities in let a = List.exists (Capability.equal capability) client_side in a && List.exists (Capability.equal capability) server_side @@ -84,12 +84,12 @@ struct Read { k = aux ~f <.> k; off; len; buffer; eof = aux ~f <.> eof } | Write { k; off; len; buffer } -> Write { k = aux ~f <.> k; off; len; buffer } - | Error err -> Error err + | Error _ as err -> err in fun m ~f -> match m with | Return v -> f v - | Error err -> Error err + | Error _ as err -> err | Read _ -> aux ~f m | Write _ -> aux ~f m diff --git a/src/not-so-smart/state.mli b/src/not-so-smart/state.mli index 4ab007c3c..96994f163 100644 --- a/src/not-so-smart/state.mli +++ b/src/not-so-smart/state.mli @@ -18,7 +18,7 @@ module type CONTEXT = sig val pp : t Fmt.t val encoder : t -> encoder val decoder : t -> decoder - val shared : Capability.t -> t -> bool + val is_cap_shared : Capability.t -> t -> bool end module type S = sig @@ -43,7 +43,6 @@ module Context : sig val make : Capability.t list -> t val capabilities : t -> Capability.t list * Capability.t list val update : t -> Capability.t list -> unit - val shared : Capability.t -> t -> bool end module Scheduler diff --git a/test/carton/test.ml b/test/carton/test.ml index 0102c544d..7f2c7ba02 100644 --- a/test/carton/test.ml +++ b/test/carton/test.ml @@ -377,7 +377,7 @@ let file = if ln_a <> ln_b then ( close_in ic_a; close_in ic_b; - false ) + false) else let bf_a = Bytes.create 0x1000 and bf_b = Bytes.create 0x1000 in let rec go () = @@ -477,10 +477,10 @@ let verify_bomb_pack () = Hashtbl.add weight offset target; Hashtbl.add where offset n; - ( try - let v = Hashtbl.find children (`Ofs base) in - Hashtbl.add children (`Ofs base) (offset :: v) - with Not_found -> Hashtbl.add children (`Ofs base) [ offset ] ); + (try + let v = Hashtbl.find children (`Ofs base) in + Hashtbl.add children (`Ofs base) (offset :: v) + with Not_found -> Hashtbl.add children (`Ofs base) [ offset ]); go decoder | `Entry _ -> (* OBJ_REF *) Alcotest.fail "Unexpected OBJ_REF" | `Malformed err -> Alcotest.fail err @@ -631,17 +631,17 @@ let unpack_bomb_pack () = Hashtbl.add weight Int64.(sub offset (Int64.of_int s)) source; Hashtbl.add weight offset target; Hashtbl.add where offset n; - ( try - let v = - Hashtbl.find children (`Ofs Int64.(sub offset (of_int s))) - in - Hashtbl.add children - (`Ofs Int64.(sub offset (of_int s))) - (offset :: v) - with _exn -> - Hashtbl.add children - (`Ofs Int64.(sub offset (of_int s))) - [ offset ] ); + (try + let v = + Hashtbl.find children (`Ofs Int64.(sub offset (of_int s))) + in + Hashtbl.add children + (`Ofs Int64.(sub offset (of_int s))) + (offset :: v) + with _exn -> + Hashtbl.add children + (`Ofs Int64.(sub offset (of_int s))) + [ offset ]); go decoder | `Entry _ -> assert false | `End _ -> @@ -952,10 +952,10 @@ let decode_index_stream () = TODO(dinosaure): we should add test to ensure that [device] did not keep our value if we don't keep [uid]. *); close_in ic; - Index_stream_decoder.close device fd ) + Index_stream_decoder.close device fd) else ( Index_stream_decoder.append device fd (Bytes.sub_string tp 0 len); - go () ) + go ()) in Gc.minor (); Gc.full_major (); diff --git a/test/index/test.ml b/test/index/test.ml index f24e44f8e..9576b6ecb 100644 --- a/test/index/test.ml +++ b/test/index/test.ml @@ -57,8 +57,7 @@ let add_should_be_empty = Alcotest.(check string) "add" "A" status; R.ok () | _ -> - Alcotest.failf "git-status: impossible to parse %S" should_be_empty - ) + Alcotest.failf "git-status: impossible to parse %S" should_be_empty) | res, _ -> Alcotest.failf "git-status: @[%a@]" Fmt.(Dump.list string) res in @@ -115,7 +114,7 @@ let tree_of_children tbl children = | Some hash -> let name = Fpath.basename path in Lwt.return_ok (Git.Tree.entry ~name `Dir hash) - | None -> Alcotest.failf "%a does not exist" Fpath.pp path ) + | None -> Alcotest.failf "%a does not exist" Fpath.pp path) in Lwt_list.map_p entry children >>= Lwt_list.map_s (Lwt.return <.> Rresult.R.get_ok) @@ -147,7 +146,7 @@ let write_tree expect = Alcotest.(check sha1) "blob" hash (Entry.oid entry); Lwt.return_ok hash | Error err -> - Alcotest.failf "store: %a" Git_unix.Store.pp_error err ) + Alcotest.failf "store: %a" Git_unix.Store.pp_error err) | `Tree path -> ( tree_of_children tbl children >>= fun tree -> Git_unix.Store.write store (Git_unix.Store.Value.tree tree) @@ -156,14 +155,14 @@ let write_tree expect = Hashtbl.add tbl path hash; Lwt.return_ok hash | Error err -> - Alcotest.failf "store: %a" Git_unix.Store.pp_error err ) + Alcotest.failf "store: %a" Git_unix.Store.pp_error err) | `Root -> ( tree_of_children tbl children >>= fun tree -> Git_unix.Store.write store (Git_unix.Store.Value.tree tree) >>= function | Ok (hash, _) -> Lwt.return_ok hash | Error err -> - Alcotest.failf "store: %a" Git_unix.Store.pp_error err ) + Alcotest.failf "store: %a" Git_unix.Store.pp_error err) in fold ~f (Digestif.SHA1.digest_string "") t in @@ -200,8 +199,7 @@ let delete_should_be_empty = Alcotest.(check string) "delete" status "D"; Bos.OS.Cmd.run Bos.Cmd.(v "git" % "commit" % "-m" % ".") | _ -> - Alcotest.failf "git-status: impossible to parse %S" should_be_empty - ) + Alcotest.failf "git-status: impossible to parse %S" should_be_empty) | res, _ -> Alcotest.failf "git-status: @[%a@]" Fmt.(Dump.list string) res in diff --git a/test/smart/dune b/test/smart/dune index 030fba177..fbe05d579 100644 --- a/test/smart/dune +++ b/test/smart/dune @@ -2,9 +2,9 @@ (name test) (libraries git git-unix result curl.lwt mirage-crypto-rng.unix digestif digestif.c domain-name git-nss.git bos fpath bigarray-compat carton-lwt - bigstringaf git-nss.sigs fmt git-nss.pck carton rresult conduit alcotest - conduit-lwt git-nss.smart lwt.unix mmap astring lwt cstruct uri fmt.tty - logs.fmt alcotest-lwt cohttp-lwt-unix git-cohttp-unix)) + bigstringaf git-nss.sigs git-nss.hkt fmt git-nss.pck carton rresult + conduit alcotest conduit-lwt git-nss.smart lwt.unix mmap astring lwt + cstruct uri fmt.tty logs.fmt alcotest-lwt cohttp-lwt-unix git-cohttp-unix)) (rule (alias runtest) diff --git a/test/smart/fifo.ml b/test/smart/fifo.ml index 90186e335..0d60994c0 100644 --- a/test/smart/fifo.ml +++ b/test/smart/fifo.ml @@ -52,7 +52,7 @@ let recv { ic; linger; closed; _ } raw = (if filled + len = 0 then `End_of_flow else `Input (filled + len)) else Lwt.return_ok - (if filled + len = 0 then `End_of_flow else `Input (filled + len)) ) + (if filled + len = 0 then `End_of_flow else `Input (filled + len))) in Lwt.catch (fun () -> process 0 raw) @@ function | Unix.Unix_error (err, _, _) -> Lwt.return_error (`Unix_error err) @@ -77,7 +77,7 @@ let rec send ({ oc; closed; linger; _ } as t) raw = in Lwt.catch process @@ function | Unix.Unix_error (err, _, _) -> Lwt.return_error (`Unix_error err) - | exn -> Lwt.fail exn ) + | exn -> Lwt.fail exn) let close t = let process () = @@ -86,7 +86,7 @@ let close t = Lwt_unix.close t.ic >>= fun () -> Lwt_unix.close t.oc >>= fun () -> t.closed <- true; - Lwt.return_ok () ) + Lwt.return_ok ()) else Lwt.return_ok () in Lwt.catch process @@ function diff --git a/test/smart/loopback.ml b/test/smart/loopback.ml index 50e11bf52..d3c87535a 100644 --- a/test/smart/loopback.ml +++ b/test/smart/loopback.ml @@ -16,7 +16,7 @@ let connect i = let recv flow buf = if Cstruct.len flow.i = 0 then ( flow.c <- true; - Lwt.return_ok `End_of_flow ) + Lwt.return_ok `End_of_flow) else let len = min (Cstruct.len buf) (Cstruct.len flow.i) in Cstruct.blit flow.i 0 buf 0 len; @@ -29,7 +29,7 @@ let send flow str = if flow.c then Lwt.return_error `Closed else ( flow.o <- Cstruct.append flow.o str; - Lwt.return_ok (Cstruct.len str) ) + Lwt.return_ok (Cstruct.len str)) let close flow = flow.c <- true; diff --git a/test/smart/lwt_backend.ml b/test/smart/lwt_backend.ml index 181034346..3a323657d 100644 --- a/test/smart/lwt_backend.ml +++ b/test/smart/lwt_backend.ml @@ -1,19 +1,21 @@ -module Scheduler = Sigs.Make_sched (struct type +'a t = 'a Lwt.t end) +module Scheduler = Hkt.Make_sched (struct type +'a t = 'a Lwt.t end) let lwt = let open Scheduler in let open Lwt.Infix in - { - Sigs.bind = (fun x f -> inj (prj x >>= fun x -> prj (f x))); - Sigs.return = (fun x -> inj (Lwt.return x)); - } + Sigs. + { + bind = (fun x f -> inj (prj x >>= fun x -> prj (f x))); + return = (fun x -> inj (Lwt.return x)); + } let lwt_io = let open Scheduler in - { - Sigs.recv = (fun flow raw -> inj (Conduit_lwt.recv flow raw)); - Sigs.send = (fun flow raw -> inj (Conduit_lwt.send flow raw)); - Sigs.pp_error = Conduit_lwt.pp_error; - } + Sigs. + { + recv = (fun flow raw -> inj (Conduit_lwt.recv flow raw)); + send = (fun flow raw -> inj (Conduit_lwt.send flow raw)); + pp_error = Conduit_lwt.pp_error; + } let lwt_fail exn = Scheduler.inj (Lwt.fail exn) diff --git a/test/smart/store_backend.ml b/test/smart/store_backend.ml index 68d9bb16e..681f80a7c 100644 --- a/test/smart/store_backend.ml +++ b/test/smart/store_backend.ml @@ -7,7 +7,7 @@ module Log = (val Logs.src_log src : Logs.LOG) type ('k, 'v) t = { tbl : ('k, 'v) Hashtbl.t; path : Fpath.t } -module Store = Sigs.Make_store (struct type nonrec ('k, 'v) t = ('k, 'v) t end) +module Store = Hkt.Make_store (struct type nonrec ('k, 'v) t = ('k, 'v) t end) type git = Store.t @@ -182,7 +182,7 @@ let preds_of_tree path uid = let uid_and_name = String.concat " " uid_and_name in match Astring.String.cut ~sep:"\t" uid_and_name with | Some (uid, _) -> R.ok uid - | None -> R.error_msgf "Invalid line: %S" line ) + | None -> R.error_msgf "Invalid line: %S" line) | _ -> R.error_msgf "Invalid line: %S" line in let open Bos in @@ -263,7 +263,7 @@ let get_object_for_packer { return; _ } uid store = | Error err -> Log.warn (fun m -> m "Got an error [get_object_for_packer]: %a" R.pp_msg err); - return None ) + return None) let get_commit_for_negotiation path (uid : Uid.t) = let open Bos in @@ -304,12 +304,12 @@ let parents : | Ok None -> assert false (* XXX(dinosaure): impossible, [git] can not give to us unknown object. *) - | Error err -> Stdlib.raise (Failure (Fmt.str "%a" R.pp_msg err)) ) + | Error err -> Stdlib.raise (Failure (Fmt.str "%a" R.pp_msg err))) in try let objs = List.map map uids in return objs - with Failure err -> failwithf "%s" err ) + with Failure err -> failwithf "%s" err) | Error err -> Log.err (fun m -> m "Got an error [parents]: %a" R.pp_msg err); failwithf "%a" R.pp_msg err @@ -379,7 +379,7 @@ let get_commit_for_negotiation { Sigs.return; _ } uid store = | Error err -> Log.warn (fun m -> m "Got an error [get_commit_for_negotiation]: %a" R.pp_msg err); - return None ) + return None) let safely_rd ~f path = Bos.OS.File.with_ic path @@ fun ic a -> diff --git a/test/smart/test.ml b/test/smart/test.ml index 1d3c36310..768ed1632 100644 --- a/test/smart/test.ml +++ b/test/smart/test.ml @@ -95,8 +95,8 @@ let create_tmp_dir ?(mode = 0o700) ?prefix_path pat = in try Ok - ( Unix.mkdir (Fpath.to_string dir) mode; - dir ) + (Unix.mkdir (Fpath.to_string dir) mode; + dir) with | Unix.Unix_error (Unix.EEXIST, _, _) -> loop (count - 1) | Unix.Unix_error (Unix.EINTR, _, _) -> loop count @@ -260,7 +260,7 @@ let test_sync_fetch () = (Git.Reference.Uid (Digestif.SHA1.of_hex "1000")) >|= store_err >>? fun () -> - Smart_git.endpoint_of_string "git://localhost/not-found.git" + Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >|= bad_input_err >>? fun endpoint -> @@ -319,7 +319,7 @@ let test_empty_clone () = Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> - Smart_git.endpoint_of_string "git://localhost/not-found.git" |> Lwt.return + Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> Git.fetch ~resolvers ~capabilities access store endpoint (`Some [ Ref.v "HEAD" ]) @@ -348,7 +348,7 @@ let test_simple_clone () = Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> - Smart_git.endpoint_of_string "git://localhost/not-found.git" |> Lwt.return + Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> Git.fetch ~resolvers ~capabilities access store endpoint `All pack index ~src:tmp0 ~dst:tmp1 ~idx:tmp2 @@ -372,15 +372,16 @@ let create_new_git_push_store _sw = |> R.join >>= fun () -> let access = - { - Sigs.get = get_object_for_packer lwt; - Sigs.parents = (fun _uid _store -> assert false); - Sigs.deref = deref lwt; - Sigs.locals = (fun _store -> assert false); - Sigs.shallowed = (fun _store -> assert false); - Sigs.shallow = (fun _store _uid -> assert false); - Sigs.unshallow = (fun _store _uid -> assert false); - } + Sigs. + { + get = get_object_for_packer lwt; + parents = (fun _uid _store -> assert false); + deref = deref lwt; + locals = (fun _store -> assert false); + shallowed = (fun _store -> assert false); + shallow = (fun _store _uid -> assert false); + unshallow = (fun _store _uid -> assert false); + } in let light_load uid = lightly_load lwt root uid |> Scheduler.prj in let heavy_load uid = heavily_load lwt root uid |> Scheduler.prj in @@ -446,7 +447,7 @@ let test_simple_push () = create_new_git_push_store sw >>= fun (access, store) -> commit_foo store >>= fun _head -> let resolvers = resolvers_with_payloads payloads in - Smart_git.endpoint_of_string "git://localhost/not-found.git" |> Lwt.return + Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> Git.push ~resolvers ~capabilities access store endpoint [ `Update (Ref.v "refs/head/master", Ref.v "refs/head/master") ] @@ -482,7 +483,7 @@ let test_push_error () = in create_new_git_push_store sw >>= fun (access, store) -> let resolvers = resolvers_with_payloads payloads in - Smart_git.endpoint_of_string "git://localhost/not-found.git" |> Lwt.return + Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> Git.push ~resolvers ~capabilities access store endpoint [ `Update (Ref.v "refs/head/master", Ref.v "refs/head/master") ] @@ -512,7 +513,7 @@ let test_fetch_empty () = Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> - Smart_git.endpoint_of_string "git://localhost/not-found.git" |> Lwt.return + Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> Git.fetch ~resolvers ~capabilities access store endpoint `All pack index ~src:tmp0 ~dst:tmp1 ~idx:tmp2 @@ -605,7 +606,7 @@ let test_fetch_empty () = Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> - Smart_git.endpoint_of_string "git://localhost/not-found.git" + Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> Git.fetch ~resolvers ~capabilities access store endpoint `All pack index @@ -1048,7 +1049,7 @@ let test_negotiation () = Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> - Smart_git.endpoint_of_string "git://localhost/not-found.git" |> Lwt.return + Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> Git.fetch ~resolvers ~capabilities access store endpoint `All pack index ~src:tmp0 ~dst:tmp1 ~idx:tmp2 @@ -1124,7 +1125,7 @@ let run_git_upload_pack ?(tmps_exit = true) store ic oc = Tmp_dirs.are_valid := tmps_exit; Logs.debug (fun m -> m "git-upload-pack terminated properly."); exit 1 - | Error (`Msg err) -> Alcotest.failf "git-upload-pack: %s" err ) + | Error (`Msg err) -> Alcotest.failf "git-upload-pack: %s" err) | _ -> Logs.app (fun m -> m "git-upload-pack launched!"); Lwt.return_unit @@ -1172,7 +1173,7 @@ let test_ssh () = Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> - Smart_git.endpoint_of_string "git@localhost:not-found.git" |> Lwt.return + Smart_git.Endpoint.of_string "git@localhost:not-found.git" |> Lwt.return >>? fun endpoint -> Logs.app (fun m -> m "Waiting git-upload-pack."); Logs.app (fun m -> m "Start to fetch repository with SSH."); @@ -1256,7 +1257,7 @@ let test_negotiation_ssh () = Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> - Smart_git.endpoint_of_string "git@localhost:not-found.git" |> Lwt.return + Smart_git.Endpoint.of_string "git@localhost:not-found.git" |> Lwt.return >>? fun endpoint -> Logs.app (fun m -> m "Waiting git-upload-pack."); Logs.app (fun m -> m "Start to fetch repository with SSH."); @@ -1296,7 +1297,7 @@ let run_git_receive_pack store ic oc = Tmp_dirs.are_valid := false; Logs.debug (fun m -> m "git-receive-pack terminated properly."); exit 1 - | Error (`Msg err) -> Alcotest.failf "git-upload-pack: %s" err ) + | Error (`Msg err) -> Alcotest.failf "git-upload-pack: %s" err) | _ -> Logs.app (fun m -> m "git-receive-pack launched!"); Lwt.return_unit @@ -1343,7 +1344,7 @@ let test_push_ssh () = update_testzone_1 store1 >>? fun () -> let capabilities = [ `Report_status; `Side_band_64k ] in let resolvers = resolvers_with_fifo ic_fifo oc_fifo in - Smart_git.endpoint_of_string "git@localhost:not-found.git" |> Lwt.return + Smart_git.Endpoint.of_string "git@localhost:not-found.git" |> Lwt.return >>? fun endpoint -> Git.push ~resolvers ~capabilities access store1 endpoint [ `Update (Ref.v "refs/heads/master", Ref.v "refs/heads/master") ] @@ -1370,7 +1371,7 @@ let test_push_ssh () = Alcotest.failf "refs/heads/master has multiple hashes: %a" Fmt.(Dump.list string) hashes - | Error (`Msg err) -> Alcotest.failf "git-show-ref: %s" err ) + | Error (`Msg err) -> Alcotest.failf "git-show-ref: %s" err) | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) | Error (#Conduit_lwt.error as err) -> Alcotest.failf "%a" Conduit_lwt.pp_error err @@ -1414,7 +1415,7 @@ let test_negotiation_http () = Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> - Smart_git.endpoint_of_string "http://localhost/not-found.git" |> Lwt.return + Smart_git.Endpoint.of_string "http://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> let queue = Queue.create () in Queue.push (load_file "GET") queue; @@ -1469,7 +1470,7 @@ let test_partial_clone_ssh () = Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> - Smart_git.endpoint_of_string "git@localhost:not-found.git" |> Lwt.return + Smart_git.Endpoint.of_string "git@localhost:not-found.git" |> Lwt.return >>? fun endpoint -> Logs.app (fun m -> m "Waiting git-upload-pack."); Logs.app (fun m -> m "Start to fetch repository with SSH."); @@ -1527,7 +1528,7 @@ let test_partial_fetch_ssh () = in let endpoint = Rresult.R.get_ok - (Smart_git.endpoint_of_string "git@localhost:not-found.git") + (Smart_git.Endpoint.of_string "git@localhost:not-found.git") in let run () = fill0 () >>? fun (_access, store0) -> @@ -1606,7 +1607,7 @@ let test_partial_fetch_ssh () = Store_backend.shallowed lwt store1 |> Scheduler.prj >>= fun shallowed -> Alcotest.(check int) "2 shallowed commits" (List.length shallowed) 2; - Lwt.return_ok () ) + Lwt.return_ok ()) in run () >>= function | Ok v -> Lwt.return v diff --git a/test/smart/unix_backend.ml b/test/smart/unix_backend.ml index 8b5e46446..168faa22d 100644 --- a/test/smart/unix_backend.ml +++ b/test/smart/unix_backend.ml @@ -1,5 +1,5 @@ -module Scheduler = Sigs.Make_sched (struct type +'a t = 'a end) +module Scheduler = Hkt.Make_sched (struct type +'a t = 'a end) let unix = let open Scheduler in - { Sigs.bind = (fun x f -> f (prj x)); Sigs.return = (fun x -> inj x) } + Sigs.{ bind = (fun x f -> f (prj x)); return = (fun x -> inj x) } diff --git a/test/test_store.ml b/test/test_store.ml index 8195fbc75..3539a8ae5 100644 --- a/test/test_store.ml +++ b/test/test_store.ml @@ -16,7 +16,7 @@ let random_reference () = let chr = Char.chr (Random.int 256) in if not (is_not_refname chr) then ( Bytes.set res !idx chr; - incr idx ) + incr idx) done; Git.Reference.v (Bytes.unsafe_to_string res)