Skip to content
Permalink
Browse files

Merge pull request #684 from zshipko/sync-results

Make fetch/pull/push results more intuitive
  • Loading branch information...
zshipko committed May 24, 2019
2 parents 79ec3f5 + 9b63012 commit 5503fd19fedc29a3ef3541f69ebe6d4fb4f563c3
@@ -20,7 +20,7 @@ let test () =
let config = Irmin_git.config Config.root in
Store.Repo.v config >>= fun repo ->
Store.master repo >>= fun t ->
Sync.pull_exn t remote `Set >>= fun () ->
Sync.pull_exn t remote `Set >>= fun _ ->
Store.get t [ "README.md" ] >>= fun readme ->
Store.get_tree t [] >>= fun tree ->
Store.Tree.add tree [ "BAR.md" ] "Hoho!" >>= fun tree ->
@@ -31,6 +31,6 @@ let test () =
Printf.printf "%s\n%!" bar;
Store.get t [ "FOO.md" ] >>= fun foo ->
Printf.printf "%s\n%!" foo;
Sync.push_exn t remote
Sync.push_exn t remote >|= ignore

let () = Lwt_main.run (test ())
@@ -16,7 +16,7 @@ let test () =
let config = Irmin_git.config Config.root in
Store.Repo.v config >>= fun repo ->
Store.master repo >>= fun t ->
Sync.pull_exn t upstream `Set >>= fun () ->
Sync.pull_exn t upstream `Set >>= fun _ ->
Store.get t [ "README.md" ] >>= fun readme ->
Store.get_tree t [] >>= fun tree ->
Store.Tree.add tree [ "BAR.md" ] "Hoho!" >>= fun tree ->
@@ -177,7 +177,7 @@ struct

let to_bin t =
let blob = G.Value.Blob.of_string (Irmin.Type.to_bin_string C.t t) in
let raw, etmp = Cstruct.create 0x100, Cstruct.create 0x100 in
let raw, etmp = (Cstruct.create 0x100, Cstruct.create 0x100) in
match Raw.to_raw ~raw ~etmp (G.Value.blob blob) with
| Error _ -> assert false
| Ok s -> s
@@ -332,7 +332,7 @@ struct
let of_n n = v (N.list n)

let to_bin t =
let raw, etmp = Cstruct.create 0x100, Cstruct.create 0x100 in
let raw, etmp = (Cstruct.create 0x100, Cstruct.create 0x100) in
match Raw.to_raw ~raw ~etmp (G.Value.tree t) with
| Error _ -> assert false
| Ok s -> s
@@ -451,7 +451,7 @@ struct
C.v ~info ~node ~parents

let to_bin t =
let raw, etmp = Cstruct.create 0x100, Cstruct.create 0x100 in
let raw, etmp = (Cstruct.create 0x100, Cstruct.create 0x100) in
match Raw.to_raw ~raw ~etmp (G.Value.commit t) with
| Error _ -> assert false
| Ok s -> s
@@ -711,7 +711,7 @@ struct

let git_of_branch r = git_of_branch_str (Irmin.Type.to_string B.t r)

let o_head_of_git = function None -> Error `No_head | Some k -> Ok (Some k)
let o_head_of_git = function None -> Ok None | Some k -> Ok (Some k)

let fetch t ?depth e br =
let uri = S.Endpoint.uri e in
@@ -373,7 +373,7 @@ struct
| Some _ ->
Schema.
[ io_field "clone"
~typ:(non_null Lazy.(force commit))
~typ:Lazy.(force commit)
~args:
Arg.
[ arg "branch" ~typ:Input.branch;
@@ -382,11 +382,10 @@ struct
~resolve:(fun _ _src branch remote ->
mk_branch s branch >>= fun t ->
Sync.fetch t remote >>= function
| Ok d -> Store.Head.set t d >|= fun () -> Ok d
| Error e ->
let err = Fmt.to_to_string Sync.pp_fetch_error e in
Lwt_result.fail err );
io_field "push" ~typ:(non_null bool)
| Ok (`Head d) -> Store.Head.set t d >|= fun () -> Ok (Some d)
| Ok `Empty -> Lwt.return_ok None
| Error (`Msg e) -> Lwt.return_error e );
io_field "push" ~typ:(Lazy.force commit)
~args:
Arg.
[ arg "branch" ~typ:Input.branch;
@@ -396,8 +395,8 @@ struct
~resolve:(fun _ _src branch remote depth ->
mk_branch s branch >>= fun t ->
Sync.push t ?depth remote >>= function
| Ok _ -> Lwt.return_ok true
| Error `No_head -> Lwt.return_ok false
| Ok (`Head commit) -> Lwt.return_ok (Some commit)
| Ok `Empty -> Lwt.return_ok None
| Error e ->
let s = Fmt.to_to_string Sync.pp_push_error e in
Lwt.return_error s );
@@ -419,11 +418,11 @@ struct
| None -> Lwt.return `Set
in
strategy >>= Sync.pull ?depth t remote >>= function
| Ok _ -> Store.Head.find t >>= Lwt.return_ok
| Ok (`Head h) -> Lwt.return_ok (Some h)
| Ok `Empty -> Lwt.return_ok None
| Error (`Msg msg) -> Lwt.return_error msg
| Error (`Conflict msg) -> Lwt.return_error ("conflict: " ^ msg)
| Error `Not_available -> Lwt.return_error "not available"
| Error `No_head -> Lwt.return_error "no head" )
)
]
| None -> []

@@ -52,35 +52,35 @@ module Git = struct
and module Git = G

module type KV_MAKER = functor (G : Irmin_git.G) (C : Irmin.Contents.S) -> S
with type
with type
key =
string
list
and type
and type
step =
string
and type
and type
contents =
C
.t
and type
and type
branch =
string
and module Git = G

module type REF_MAKER = functor (G : Irmin_git.G) (C : Irmin.Contents.S) -> S
with type
with type
key =
string
list
and type
and type
step =
string
and type
and type
contents =
C
.t
and type
and type
branch =
Irmin_git
.reference
@@ -253,7 +253,7 @@ module Git = struct
let head = G.Reference.of_string ("refs/heads/" ^ branch) in
S.repo_of_git ~bare:true ~head t >>= fun repo ->
S.of_branch repo branch >>= fun t ->
Sync.pull_exn t ~depth remote `Set >|= fun () ->
Sync.pull_exn t ~depth remote `Set >|= fun _ ->
let root = path root in
{ t; root }

@@ -381,7 +381,7 @@ module Git = struct
type write_error = [ RO.error | Mirage_kv.write_error | RO.Sync.push_error ]

let write_error = function
| Ok _ as x -> x
| Ok _ -> Ok ()
| Error e -> Error (e :> write_error)

let pp_write_error ppf = function
@@ -1323,7 +1323,15 @@ module Make (S : S) = struct
Alcotest.(check int) "history-e" 2 (S.History.nb_edges h);
let remote = Irmin.remote_store (module S) t1 in
Sync.fetch_exn t1 ~depth:0 remote >>= fun partial ->
let partial =
match partial with
| `Head x -> x
| `Empty -> failwith "no head: partial"
in
Sync.fetch_exn t1 remote >>= fun full ->
let full =
match full with `Head x -> x | `Empty -> failwith "no head: full"
in
(* Restart a fresh store and import everything in there. *)
let tag = "export" in
S.of_branch repo tag >>= fun t2 ->
@@ -325,8 +325,9 @@ let clone =
( store >>= fun t ->
remote >>= fun r ->
Sync.fetch t ?depth (apply r f) >>= function
| Ok d -> S.Head.set t d
| Error e -> failwith (Fmt.to_to_string Sync.pp_fetch_error e) )
| Ok (`Head d) -> S.Head.set t d
| Ok `Empty -> Lwt.return_unit
| Error (`Msg e) -> failwith e )
in
Term.(mk clone $ store $ remote $ depth))
}
@@ -344,7 +345,7 @@ let fetch =
remote >>= fun r ->
let branch = branch S.Branch.t "import" in
S.of_branch (S.repo t) branch >>= fun t ->
Sync.pull_exn t (apply r f) `Set )
Sync.pull_exn t (apply r f) `Set >>= fun _ -> Lwt.return_unit )
in
Term.(mk fetch $ store $ remote))
}
@@ -391,7 +392,7 @@ let pull =
( store >>= fun t ->
remote >>= fun r ->
Sync.pull_exn t (apply r f) (`Merge (Info.v ?author "%s" message))
)
>>= fun _ -> Lwt.return_unit )
in
Term.(mk pull $ store $ author $ message $ remote))
}
@@ -405,7 +406,9 @@ let push =
(let push (S ((module S), store, f)) remote =
let module Sync = Irmin.Sync (S) in
run
(store >>= fun t -> remote >>= fun r -> Sync.push_exn t (apply r f))
( store >>= fun t ->
remote >>= fun r ->
Sync.push_exn t (apply r f) >>= fun _ -> Lwt.return_unit )
in
Term.(mk push $ store $ remote))
}
@@ -2008,8 +2008,7 @@ module Private : sig
?depth:int ->
endpoint ->
branch ->
(commit option, [ `No_head | `Not_available | `Msg of string ]) result
Lwt.t
(commit option, [ `Msg of string ]) result Lwt.t
(** [fetch t uri] fetches the contents of the remote store
located at [uri] into the local store [t]. Return the head
of the remote branch with the same name, which is now in the
@@ -2020,10 +2019,7 @@ module Private : sig
?depth:int ->
endpoint ->
branch ->
( unit,
[ `No_head | `Not_available | `Msg of string | `Detached_head ] )
result
Lwt.t
(unit, [ `Msg of string | `Detached_head ]) result Lwt.t
(** [push t uri] pushes the contents of the local store [t] into
the remote store located at [uri]. *)
end
@@ -3408,28 +3404,27 @@ module type SYNC = sig
(** The type for store heads. *)
type commit

(** The type for fetch errors. *)
type fetch_error = [ `No_head | `Not_available | `Msg of string ]
type status = [ `Empty | `Head of commit ]

val pp_fetch_error : fetch_error Fmt.t
(** [pp_fetch_error] pretty prints fetch errors. *)

val fetch : db -> ?depth:int -> remote -> (commit, fetch_error) result Lwt.t
val fetch :
db -> ?depth:int -> remote -> (status, [ `Msg of string ]) result Lwt.t
(** [fetch t ?depth r] populate the local store [t] with objects for
the remote store [r], using [t]'s current branch. The [depth]
parameter limits the history depth. Return [None] if either the
parameter limits the history depth. Return [`Empty] if either the
local or remote store do not have a valid head. *)

val fetch_exn : db -> ?depth:int -> remote -> commit Lwt.t
val fetch_exn : db -> ?depth:int -> remote -> status Lwt.t
(** Same as {!fetch} but raise [Invalid_argument] if either the
local or remote store do not have a valid head. *)

type pull_error = [ `Msg of string | Merge.conflict ]

val pull :
db ->
?depth:int ->
remote ->
[ `Merge of Info.f | `Set ] ->
(unit, [ fetch_error | Merge.conflict ]) result Lwt.t
(status, pull_error) result Lwt.t
(** [pull t ?depth r s] is similar to {{!Sync.fetch}fetch} but it
also updates [t]'s current branch. [s] is the update strategy:
@@ -3439,16 +3434,16 @@ module type SYNC = sig
} *)

val pull_exn :
db -> ?depth:int -> remote -> [ `Merge of Info.f | `Set ] -> unit Lwt.t
db -> ?depth:int -> remote -> [ `Merge of Info.f | `Set ] -> status Lwt.t
(** Same as {!pull} but raise [Invalid_arg] in case of conflict. *)

(** The type for push errors. *)
type push_error = [ fetch_error | `Detached_head ]
type push_error = [ `Msg of string | `Detached_head ]

val pp_push_error : push_error Fmt.t
(** [pp_push_error] pretty-prints push errors. *)

val push : db -> ?depth:int -> remote -> (unit, push_error) result Lwt.t
val push : db -> ?depth:int -> remote -> (status, push_error) result Lwt.t
(** [push t ?depth r] populates the remote store [r] with objects
from the current store [t], using [t]'s current branch. If [b]
is [t]'s current branch, [push] also updates the head of [b] in
@@ -3457,7 +3452,7 @@ module type SYNC = sig
{b Note:} {e Git} semantics is to update [b] only if the new
head if more recent. This is not the case in {e Irmin}. *)

val push_exn : db -> ?depth:int -> remote -> unit Lwt.t
val push_exn : db -> ?depth:int -> remote -> status Lwt.t
(** Same as {!push} but raise [Invalid_argument] if an error
happens. *)
end
@@ -403,18 +403,14 @@ module type SYNC = sig
?depth:int ->
endpoint ->
branch ->
(commit option, [ `No_head | `Not_available | `Msg of string ]) result
Lwt.t
(commit option, [ `Msg of string ]) result Lwt.t

val push :
t ->
?depth:int ->
endpoint ->
branch ->
( unit,
[ `No_head | `Not_available | `Msg of string | `Detached_head ] )
result
Lwt.t
(unit, [ `Msg of string | `Detached_head ]) result Lwt.t
end

module type PRIVATE = sig
@@ -1052,29 +1048,30 @@ module type SYNC_STORE = sig

type commit

type fetch_error = [ `No_head | `Not_available | `Msg of string ]
type push_error = [ `Msg of string | `Detached_head ]

val pp_fetch_error : fetch_error Fmt.t
type pull_error = [ `Msg of string | Merge.conflict ]

type push_error = [ fetch_error | `Detached_head ]
type status = [ `Empty | `Head of commit ]

val fetch : db -> ?depth:int -> remote -> (commit, fetch_error) result Lwt.t
val fetch :
db -> ?depth:int -> remote -> (status, [ `Msg of string ]) result Lwt.t

val fetch_exn : db -> ?depth:int -> remote -> commit Lwt.t
val fetch_exn : db -> ?depth:int -> remote -> status Lwt.t

val pull :
db ->
?depth:int ->
remote ->
[ `Merge of Info.f | `Set ] ->
(unit, [ fetch_error | Merge.conflict ]) result Lwt.t
(status, pull_error) result Lwt.t

val pull_exn :
db -> ?depth:int -> remote -> [ `Merge of Info.f | `Set ] -> unit Lwt.t
db -> ?depth:int -> remote -> [ `Merge of Info.f | `Set ] -> status Lwt.t

val pp_push_error : push_error Fmt.t

val push : db -> ?depth:int -> remote -> (unit, push_error) result Lwt.t
val push : db -> ?depth:int -> remote -> (status, push_error) result Lwt.t

val push_exn : db -> ?depth:int -> remote -> unit Lwt.t
val push_exn : db -> ?depth:int -> remote -> status Lwt.t
end
@@ -25,7 +25,9 @@ module None (H : Type.S) (R : Type.S) = struct

type branch = R.t

let fetch () ?depth:_ _ _br = Lwt.return (Error `Not_available)
let fetch () ?depth:_ _ _br =
Lwt.return_error (`Msg "fetch operation is not available")

let push () ?depth:_ _ _br = Lwt.return (Error `Not_available)
let push () ?depth:_ _ _br =
Lwt.return_error (`Msg "push operation is not available")
end

0 comments on commit 5503fd1

Please sign in to comment.
You can’t perform that action at this time.