Updates to fetch/push/pull API

src/irmin-git/irmin_git.ml

@@ -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
@@ -756,7 +756,7 @@ struct
           | Error (r, e) ->
               errors := Fmt.strf "%a: %s" G.Reference.pp r e :: !errors )
         refs;
-      if !errors = [] then Ok ()
+      if !errors = [] then Ok `Success
       else
         Fmt.kstrf
           (fun e -> Error (`Msg e))

src/irmin-graphql/server.ml

@@ -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,10 +382,9 @@ 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 );
+                | Ok (Some d) -> Store.Head.set t d >|= fun () -> Ok (Some d)
+                | Ok None -> Lwt.return_ok None
+                | Error (`Msg e) -> Lwt.return_error e );
             io_field "push" ~typ:(non_null bool)
               ~args:
                 Arg.
@@ -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 `Success -> Lwt.return_ok true
+                | Ok `No_head -> Lwt.return_ok false
                 | 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 `Success -> Store.Head.find t >>= Lwt.return_ok
+                | Ok `No_head -> 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 -> []
 

src/irmin-mirage/irmin_mirage.ml

@@ -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

src/irmin-test/store.ml

@@ -1323,7 +1323,13 @@ 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 Some x -> x | None -> failwith "no head: partial"
+      in
       Sync.fetch_exn t1 remote >>= fun full ->
+      let full =
+        match full with Some x -> x | None -> 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 ->

src/irmin-unix/cli.ml

@@ -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 (Some d) -> S.Head.set t d
+             | Ok None -> 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))
   }

src/irmin/irmin.mli

@@ -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,9 +2019,7 @@ module Private : sig
         ?depth:int ->
         endpoint ->
         branch ->
-        ( unit,
-          [ `No_head | `Not_available | `Msg of string | `Detached_head ] )
-        result
+        ([ `No_head | `Success ], [ `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]. *)
@@ -3408,28 +3405,28 @@ 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 ]
-
-  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 ->
+    (commit option, [ `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
       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 -> commit option 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
+    ([ `No_head | `Success ], 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 +3436,24 @@ 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 ] ->
+    [ `No_head | `Success ] 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 ->
+    ([ `No_head | `Success ], 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 +3462,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 -> [ `No_head | `Success ] Lwt.t
   (** Same as {!push} but raise [Invalid_argument] if an error
       happens. *)
 end

src/irmin/s.ml

@@ -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
+    ([ `No_head | `Success ], [ `Msg of string | `Detached_head ]) result Lwt.t
 end
 
 module type PRIVATE = sig
@@ -1052,29 +1048,39 @@ 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 ]
-
-  val fetch : db -> ?depth:int -> remote -> (commit, fetch_error) result Lwt.t
+  val fetch :
+    db ->
+    ?depth:int ->
+    remote ->
+    (commit option, [ `Msg of string ]) result Lwt.t
 
-  val fetch_exn : db -> ?depth:int -> remote -> commit Lwt.t
+  val fetch_exn : db -> ?depth:int -> remote -> commit option Lwt.t
 
   val pull :
     db ->
     ?depth:int ->
     remote ->
     [ `Merge of Info.f | `Set ] ->
-    (unit, [ fetch_error | Merge.conflict ]) result Lwt.t
+    ([ `No_head | `Success ], 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 ] ->
+    [ `No_head | `Success ] 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 ->
+    ([ `No_head | `Success ], push_error) result Lwt.t
 
-  val push_exn : db -> ?depth:int -> remote -> unit Lwt.t
+  val push_exn : db -> ?depth:int -> remote -> [ `No_head | `Success ] Lwt.t
 end

src/irmin/sync.ml

@@ -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