test_fufpf.ml

#!/usr/bin/env ocaml

#use "topfind";;
#thread;;
#require "unix";;
#require "git-unix";;
#require "mtime";;
#require "mtime.clock.os";;
#require "fmt.tty";;

module Option =
struct
  let map f = function
    | Some v -> Some (f v)
    | None -> None
end

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 = Mtime.Span.to_us (Mtime_clock.elapsed ()) in
      Fmt.kpf k ppf ("%s %a %a: @[" ^^ fmt ^^ "@]@.")
        (pad 10 (Fmt.strf "%+04.0fus" dt))
        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 = report }

let setup_logs style_renderer level =
  Fmt_tty.setup_std_outputs ?style_renderer ();
  Logs.set_level level;
  Logs.set_reporter (reporter Fmt.stdout)

let () = setup_logs (Some `Ansi_tty) (Some Logs.Debug)

let repository = Uri.of_string "http://github.com/dinosaure/test_fetch_some.git"
let root = Fpath.v "camelus"
let locks = Fpath.(root / ".locks")

open Lwt_result

let ( >!= ) = Lwt_result.bind_lwt_err

module Store = Git_unix.FS
module Sync = Git_unix.HTTP(Store)
module Index = Git.Index.Container(Store)

let references =
  let open Store.Reference in
  Map.add Path.(heads / master) [ Path.(heads / master) ]
  @@ Map.add Path.(heads / "2.0.0") [ Path.(heads / "2.0.0") ]
  @@ Map.empty

let pp_updated ppf map =
  Fmt.Dump.list (Fmt.Dump.pair Store.Reference.pp Store.Hash.pp) ppf (Store.Reference.Map.bindings map)

let pp_missed ppf map =
  Fmt.Dump.list (Fmt.Dump.pair Store.Reference.pp (Fmt.Dump.list Store.Reference.pp)) ppf (Store.Reference.Map.bindings map)

let pp_results ppf lst =
  Fmt.Dump.list (Fmt.Dump.result ~ok:Store.Reference.pp ~error:(Fmt.Dump.pair Store.Reference.pp Fmt.string)) ppf lst

let ( >|= ) = Lwt.bind

let err_store x = Lwt.return (`Store x)
let err_ref   x = Lwt.return (`Ref x)
let err_sync  x = Lwt.return (`Sync x)
let err_index x = Lwt.return (`Index x)

let fetch () =
  (Store.create ~root () >!= err_store) >>= fun t ->
  (Sync.fetch_some t ~locks
     ~references
     repository
   >!= err_sync) >>= fun (updated, missed) ->
  Fmt.(pf stdout) "updated: %a.\n%!"
    (Fmt.hvbox pp_updated) updated;
  Fmt.(pf stdout) "missed: %a.\n%!"
    (Fmt.hvbox pp_missed) missed;
  (Store.Ref.write t ~locks Store.Reference.head Store.Reference.(Ref Path.(heads / master))
   >!= err_ref) >>= fun () ->
  (Index.from_reference t Store.Reference.head
   >!= err_index) >>= fun entries ->
  (Index.from_entries t ~dtmp:(Cstruct.create 0x8000) entries
   >!= err_index) >>= fun () ->
  Fmt.(pf stdout) "\n%!";
  Fmt.(pf stdout) "-=-=-=-=-=- %a -=-=-=-=-=-\n%!"
    Fmt.(styled `Yellow string) "FETCH PROCESS";
  Fmt.(pf stdout) "\n%!";
  Lwt.return (Ok ())

let user =
  let epoch = 1514113980L in

  let open Git.User in
  { name = "Romain Calascibetta"
  ; email = "romain.calascibetta@gmail.com"
  ; date  = (epoch, None) }

let update () =
  (Store.create ~root () >!= err_store) >>= fun t ->
  Store.Ref.list ~locks t >|= fun local_refs ->
  let open Store.Reference in
  let hash_of_master = List.assoc Path.(heads / master) local_refs in
  let hash_of_2_0_0  = List.assoc Path.(heads / "2.0.0") local_refs in

  (Store.read t hash_of_master
   >!= err_store) >>= fun commit_of_master ->
  (Store.read t hash_of_2_0_0
   >!= err_store) >>= fun commit_of_2_0_0 ->

  let readme = Store.Value.Blob.of_cstruct (Cstruct.of_string "New update") in

  (Store.write t (Store.Value.blob readme) >!= err_store) >>= fun (hash_blob, _) ->

  let root_tree =
    let open Store.Value.Tree in
    let entry =
      { perm = `Normal
      ; name = "README.md"
      ; node = hash_blob } in
    of_list [ entry ]
  in

  (Store.write t (Store.Value.tree root_tree) >!= err_store) >>= fun (hash_tree, _) ->

  let commit =
    Store.Value.Commit.make
      ~author:user
      ~committer:user
      ~parents:[ hash_of_master
               ; hash_of_2_0_0 ]
      ~tree:hash_tree
      "Not a merge."
  in

  (Store.write t (Store.Value.commit commit) >!= err_store) >>= fun (hash_commit, _) ->

  let open Store.Reference in

  (Store.Ref.write t ~locks Path.(heads / master) (Hash hash_commit) >!= err_ref) >>= fun () ->
  Fmt.(pf stdout) "\n%!";
  Fmt.(pf stdout) "-=-=-=-=-=- %a -=-=-=-=-=-\n%!"
    Fmt.(styled `Yellow string) "UPDATE PROCESS";
  Fmt.(pf stdout) "\n%!";
  Lwt.return (Ok ())

let token = ""

let headers ~user ~token =
  Cohttp.Header.add_authorization
    (Cohttp.Header.init ())
    (`Basic (user, token))

let push () =
  (Store.create ~root () >!= err_store) >>= fun t ->
  (Sync.update_and_create t
     ~headers:(headers ~user:"dinosaure" ~token)
     ~references
     repository
   >!= err_sync) >>= fun results ->
  Fmt.(pf stdout) "results: %a.\n%!"
    (Fmt.hvbox pp_results) results;
  Fmt.(pf stdout) "\n%!";
  Fmt.(pf stdout) "-=-=-=-=-=- %a -=-=-=-=-=-\n%!"
    Fmt.(styled `Yellow string) "PUSH PROCESS";
  Fmt.(pf stdout) "\n%!";
  Lwt.return (Ok ())

let ( <.> ) f g = fun x -> f (g x)

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
  | `Ref err -> Fmt.pf ppf "(`Ref %a)" Store.Ref.pp_error err
  | `Index err -> Fmt.pf ppf "(`Index %a)" Index.pp_error err

let result t = let open Lwt.Infix in t >>= function
  | Ok v -> Lwt.return v
  | Error err -> Lwt.fail (Failure (Fmt.strf "%a" pp_error err))

let () =
  Lwt_main.run ((result <.> (fun x -> fetch x >>= update >>= fetch >>= push >>= fetch)) ())