Server-side command: upload-pack

bin/guit/dune

@@ -27,6 +27,35 @@
   mimic
   git-unix))
 
+(executable
+ (name upload_pack)
+ (modules upload_pack)
+ (package git-unix)
+ (public_name guit.upload_pack)
+ (libraries
+  happy-eyeballs-lwt
+  git
+  git.nss.git
+  logs
+  logs.fmt
+  fmt
+  mtime
+  mtime.clock.os
+  lwt
+  lwt.unix
+  fmt.cli
+  logs.cli
+  cstruct
+  domain-name
+  mirage-flow
+  fmt.tty
+  fpath
+  result
+  cmdliner
+  rresult
+  mimic
+  git-unix))
+
 (executable
  (name v)
  (modules v)

bin/guit/upload_pack.ml

@@ -0,0 +1,142 @@
+let () = Random.self_init ()
+
+open Git_unix
+module Sync = Sync (Store)
+
+let src = Logs.Src.create "guit-upload-pack" ~doc:"logs binary event"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let pad n x =
+  if String.length x > n then x else x ^ String.make (n - String.length x) ' '
+
+let pp_header ppf (level, header) =
+  let level_style =
+    match level with
+    | Logs.App -> Logs_fmt.app_style
+    | Logs.Debug -> Logs_fmt.debug_style
+    | Logs.Warning -> Logs_fmt.warn_style
+    | Logs.Error -> Logs_fmt.err_style
+    | Logs.Info -> Logs_fmt.info_style
+  in
+  let level = Logs.level_to_string (Some level) in
+  Fmt.pf ppf "[%a][%a]"
+    (Fmt.styled level_style Fmt.string)
+    level (Fmt.option Fmt.string)
+    (Option.map (pad 10) header)
+
+let reporter ppf =
+  let report src level ~over k msgf =
+    let k _ =
+      over ();
+      k ()
+    in
+    let with_src_and_stamp h _ k fmt =
+      let dt_us = 1e-3 *. Int64.to_float (Mtime_clock.elapsed_ns ()) in
+      Fmt.kpf k ppf
+        ("%s %a %a: @[" ^^ fmt ^^ "@]@.")
+        (pad 10 (Fmt.str "%+04.0fus" dt_us))
+        pp_header (level, h)
+        Fmt.(styled `Magenta string)
+        (pad 10 @@ Logs.Src.name src)
+    in
+    msgf @@ fun ?header ?tags fmt -> with_src_and_stamp header tags k fmt
+  in
+  { Logs.report }
+
+let setup_logs style_renderer level ppf =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter (reporter ppf);
+  let quiet = match level with Some _ -> false | None -> true in
+  quiet, ppf
+
+type error = [ `Store of Store.error | `Sync of Sync.error ]
+
+let store_err err = `Store err
+let sync_err err = `Sync err
+
+let pp_error ppf = function
+  | `Store err -> Fmt.pf ppf "(`Store %a)" Store.pp_error err
+  | `Sync err -> Fmt.pf ppf "(`Sync %a)" Sync.pp_error err
+
+let main quiet (directory : string) : (unit, 'error) Lwt_result.t =
+  let root =
+    (match directory with "" -> Sys.getcwd () | _ -> directory) |> Fpath.v
+  in
+  let ( >>? ) = Lwt_result.bind in
+  let ( >>?? ) = Lwt.bind in
+  let ( >>! ) v f = Lwt_result.map_error f v in
+  Store.v root >>! store_err >>? fun store ->
+  let _push_stdout, _push_stderr =
+    match quiet with
+    | true -> ignore, ignore
+    | false -> print_string, prerr_string
+  in
+  Git_unix.std_in_out_ctx () >>?? fun ctx ->
+  Mimic.resolve ctx >>? fun flow ->
+  Sync.upload_pack ~flow store >>?? Lwt.return_ok
+(* >>! sync_err *)
+(* >>? fun _ -> Lwt.return (Ok ()) *)
+
+open Cmdliner
+
+(* XXX(ulugbekna): We want ogit-fetch to have the following interface:
+ * ogit-fetch [-r <path> | --root <path>] [--output <output_channel>]
+ * [--progress] <repository> <refspec>... *)
+
+let output =
+  let converter =
+    let parse str =
+      match str with
+      | "stdout" -> Ok Fmt.stdout
+      | "stderr" -> Ok Fmt.stderr
+      | s -> Error (`Msg (Fmt.str "%s is not an output." s))
+    in
+    let print ppf v =
+      Fmt.pf ppf "%s" (if v == Fmt.stdout then "stdout" else "stderr")
+    in
+    Arg.conv ~docv:"<output>" (parse, print)
+  in
+  let doc =
+    "Output of the progress status. Can take values 'stdout' (default) or \
+     'stderr'."
+  in
+  Arg.(
+    value & opt converter Fmt.stdout & info [ "output" ] ~doc ~docv:"<output>")
+
+let directory =
+  let doc = "Indicate path to repository root containing '.git' folder" in
+  Arg.(value & opt string "" & info [ "r"; "root" ] ~doc ~docv:"<directory>")
+
+(* XXX(ulugbekna): 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.Endpoint.pp in
+    Arg.conv ~docv:"<uri>" (parse, print)
+  in
+  let doc = "URI leading to repository" in
+  Arg.(
+    required & pos 0 (some endpoint) None & info [] ~docv:"<repository>" ~doc)
+
+let setup_logs =
+  let docs = Manpage.s_common_options in
+  Term.(
+    const setup_logs
+    $ Fmt_cli.style_renderer ~docs ()
+    $ Logs_cli.level ~docs ()
+    $ output)
+
+let main (quiet, _) directory =
+  match Lwt_main.run (main quiet directory) with
+  | Ok () -> Ok ()
+  | Error (#error as err) -> Error (Fmt.str "%a." pp_error err)
+  | Error _ -> Error "other"
+
+let command =
+  let doc = "Answer to a fetch." in
+  let info = Cmd.info "upload-pack" ~doc in
+  Cmd.v info Term.(const main $ setup_logs $ directory)
+
+let () = exit @@ Cmd.eval_result command

src/git-unix/git_unix.ml

@@ -747,3 +747,5 @@ module Sync (Git_store : Git.S) = struct
   let push ~ctx edn store ?version ?capabilities cmds =
     push ~ctx edn store ?version ?capabilities cmds
 end
+
+let std_in_out_ctx = Git_unix_mimic.std_in_out_ctx

src/git-unix/git_unix.mli

@@ -39,3 +39,5 @@ module Store : sig
       function should be registered with [at_exit] to clean pending
       file-descriptors. *)
 end
+
+val std_in_out_ctx : unit -> Mimic.ctx Lwt.t

src/git-unix/git_unix_mimic.ml

@@ -88,13 +88,12 @@ module TCP = struct
   let unlisten _ = assert false
 end
 
-module FIFO = struct
+module Lwt_unix_file_descr_flow = struct
   open Lwt.Infix
 
   let ( >>? ) = Lwt_result.bind
 
   type flow = Lwt_unix.file_descr * Lwt_unix.file_descr
-  type endpoint = Fpath.t
   type error = [ `Error of Unix.error * string * string ]
   type write_error = [ `Closed | `Error of Unix.error * string * string ]
 
@@ -132,6 +131,12 @@ module FIFO = struct
     | x :: r -> write fd x >>? fun () -> writev fd r
 
   let close (ic, oc) = Lwt_unix.close ic >>= fun () -> Lwt_unix.close oc
+end
+
+module FIFO = struct
+  include Lwt_unix_file_descr_flow
+
+  type endpoint = Fpath.t
 
   let connect fpath =
     let process () =
@@ -184,3 +189,14 @@ let ctx happy_eyeballs =
       ~k:k2 ctx
   in
   C.with_optional_tls_config_and_headers ctx
+
+module Std_in_out = struct
+  include Lwt_unix_file_descr_flow
+
+  type endpoint = unit
+
+  let connect () = Lwt.return_ok Lwt_unix.(stdin, stdout)
+end
+
+let std_endpoint, _ = Mimic.register ~name:"std" (module Std_in_out)
+let std_in_out_ctx () = Lwt.return (Mimic.add std_endpoint () Mimic.empty)

src/git/dune

@@ -5,6 +5,8 @@
   hxd.core
   hxd.string
   mimic
+  mirage-flow
+  git.nss.unixiz
   rresult
   git.nss.sigs
   git.nss.pck

src/git/sync.ml

@@ -51,6 +51,8 @@ module type S = sig
     | `Update of Reference.t * Reference.t ]
     list ->
     (unit, error) result Lwt.t
+
+  val upload_pack : flow:Mimic.flow -> store -> unit Lwt.t
 end
 
 module Make
@@ -181,7 +183,7 @@ struct
         Lwt.return (Carton.Dec.v ~kind raw)
     | None -> Lwt.fail Not_found
 
-  include Smart_git.Make (Scheduler) (Pack) (Index) (Hash) (Reference)
+  include Smart_git.Make_client (Scheduler) (Pack) (Index) (Hash) (Reference)
 
   let ( >>? ) x f =
     x >>= function Ok x -> f x | Error err -> Lwt.return_error err
@@ -293,4 +295,30 @@ struct
     push ~ctx
       (access, lightly_load t, heavily_load t)
       ministore endpoint ?version ?capabilities cmds
+
+  module Flow = Unixiz.Make (Mimic)
+
+  include
+    Smart_git.Make_server (Scheduler) (Flow) (Pack) (Index) (Hash) (Reference)
+
+  let access =
+    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 t -> Scheduler.inj (locals (Ministore.prj t)));
+        shallowed = (fun _ -> assert false);
+        shallow = (fun _ -> assert false);
+        unshallow = (fun _ -> assert false);
+      }
+
+  let upload_pack ~flow t =
+    let ministore = Ministore.inj (t, Hashtbl.create 0x100) in
+    upload_pack (Flow.make flow)
+      (access, lightly_load t, heavily_load t)
+      ministore
 end

src/git/sync.mli

@@ -50,6 +50,8 @@ module type S = sig
     | `Update of Reference.t * Reference.t ]
     list ->
     (unit, error) result Lwt.t
+
+  val upload_pack : flow:Mimic.flow -> store -> unit Lwt.t
 end
 
 (** Creates a lower-level [Sync] functions [fetch] and [push] that are then
@@ -106,4 +108,7 @@ module Make
     | `Update of Reference.t * Reference.t ]
     list ->
     (unit, ([> error ] as 'err)) result Lwt.t
+
+  val upload_pack : flow:Mimic.flow -> store -> unit Lwt.t
+  (** Answers a [git fetch] *)
 end

src/not-so-smart/dune

@@ -43,7 +43,7 @@
 (library
  (name nss)
  (public_name git.nss)
- (modules nss fetch push)
+ (modules nss fetch push upload_pack)
  (libraries
   fmt
   result