oplevel/store.ml

open Js_of_ocaml
open Lwt.Infix
module F = Fmt
module Cohttp_backend = Cohttp_lwt_jsoo

module Git_af = struct
  open Lwt.Infix

  type error = |

  let git_af_scheme : [ `HTTP | `HTTPS ] Mimic.value =
    Mimic.make ~name:"git-af-scheme"

  let git_af_port : int Mimic.value = Mimic.make ~name:"git-af-port"

  let git_af_hostname : string Mimic.value =
    Mimic.make ~name:"git-af-hostname"

  let pp_error : error Fmt.t = fun _ppf -> function _ -> .

  let with_redirects ?(max = 10) ~f uri =
    if max < 10 then invalid_arg "with_redirects";
    let tbl = Hashtbl.create 0x10 in
    let rec go max uri =
      f uri >>= fun (resp, body) ->
      let status_code =
        Cohttp.(Response.status resp |> Code.code_of_status)
      in
      if Cohttp.Code.is_redirection status_code then
        match
          Cohttp.(Response.headers resp |> Header.get_location)
        with
        | Some uri' when Hashtbl.mem tbl uri' || max = 0 ->
            Lwt.return (resp, body)
        | Some uri' ->
            Hashtbl.add tbl uri' ();
            Cohttp_lwt.Body.drain_body body >>= fun () ->
            go (pred max) uri'
        | None -> Lwt.return (resp, body)
      else Lwt.return (resp, body)
    in
    go max uri

  let get ~ctx:_ ?(headers = []) uri =
    Firebug.console##log (Js.string "Git_Cohttp_console.get()\n");
    let headers = Cohttp.Header.of_list headers in
    let f uri = Cohttp_backend.Client.get ~headers uri in
    with_redirects ~f uri >>= fun (_resp, body) ->
    Cohttp_lwt.Body.to_string body >>= fun body ->
    Lwt.return_ok ((), body)

  let post ~ctx:_ ?(headers = []) uri body =
    let headers = Cohttp.Header.of_list headers in
    let body = Cohttp_lwt.Body.of_string body in
    let f uri =
      Cohttp_backend.Client.post ~headers ~chunked:false ~body uri
    in
    with_redirects ~f uri >>= fun (_resp, body) ->
    Cohttp_lwt.Body.to_string body >>= fun body ->
    Lwt.return_ok ((), body)
end

module Git_console_http = struct
  open Lwt.Infix

  let context ctx =
    (* HTTP *)
    let edn = Mimic.make ~name:"af-http-endpoint" in
    let k1 git_af_scheme git_af_hostname git_af_port =
      match git_af_scheme with
      | `HTTP -> Lwt.return_some (git_af_hostname, git_af_port)
      | _ -> Lwt.return_none
    in
    let ctx =
      Mimic.fold edn
        Mimic.Fun.
          [
            req Git_af.git_af_scheme;
            req Git_af.git_af_hostname;
            dft Git_af.git_af_port 80;
          ]
        ~k:k1 ctx
    in

    (* HTTPS *)
    let edn = Mimic.make ~name:"af-https-endpoint" in
    let k1 git_af_scheme git_af_hostname git_af_port =
      match git_af_scheme with
      | `HTTPS -> Lwt.return_some (git_af_hostname, git_af_port)
      | _ -> Lwt.return_none
    in

    let ctx =
      Mimic.fold edn
        Mimic.Fun.
          [
            req Git_af.git_af_scheme;
            req Git_af.git_af_hostname;
            dft Git_af.git_af_port 443;
          ]
        ~k:k1 ctx
    in

    ctx

  module HTTP = struct
    type state =
      | Handshake
      | Get of {
          advertised_refs : string;
          uri : Uri.t;
          headers : (string * string) list;
          ctx : Mimic.ctx;
        }
      | Post of {
          mutable output : string;
          uri : Uri.t;
          headers : (string * string) list;
          ctx : Mimic.ctx;
        }
      | Error

    type flow = { endpoint : Uri.t; mutable state : state }
    type error = [ `Msg of string ]
    type write_error = [ `Closed | `Msg of string ]

    let pp_error ppf (`Msg err) = Fmt.string ppf err

    let pp_write_error ppf = function
      | `Closed -> Fmt.string ppf "Connection closed by peer"
      | `Msg err -> Fmt.string ppf err

    let write t cs =
      match t.state with
      | Handshake | Get _ ->
          Lwt.return_error (`Msg "Handshake has not been done")
      | Error -> Lwt.return_error (`Msg "Handshake got an error")
      | Post ({ output; _ } as v) ->
          let output = output ^ Cstruct.to_string cs in
          v.output <- output;
          Lwt.return_ok ()

    let writev t css =
      let rec go = function
        | [] -> Lwt.return_ok ()
        | x :: r -> (
            write t x >>= function
            | Ok () -> go r
            | Error _ as err -> Lwt.return err)
      in
      go css

    let read t =
      match t.state with
      | Handshake ->
          Lwt.return_error (`Msg "Handshake has not been done")
      | Error -> Lwt.return_error (`Msg "Handshake got an error")
      | Get { advertised_refs; uri; headers; ctx } ->
          t.state <- Post { output = ""; uri; headers; ctx };
          Lwt.return_ok (`Data (Cstruct.of_string advertised_refs))
      | Post { output; uri; headers; ctx } -> (
          Git_af.post ~ctx ~headers uri output >>= function
          | Ok (_resp, contents) ->
              Lwt.return_ok (`Data (Cstruct.of_string contents))
          | Error err ->
              Lwt.return_error
                (`Msg (Fmt.str "%a" Git_af.pp_error err)))

    let close _ = Lwt.return_unit

    type endpoint = Uri.t

    let connect endpoint =
      Firebug.console##log
        (Js.string "Git_Console_http.HTTP.connect()\n");
      Lwt.return_ok { endpoint; state = Handshake }
  end

  let http_endpoint, http_protocol =
    Mimic.register ~name:"http" (module HTTP)

  let connect (ctx : Mimic.ctx) =
    Firebug.console##log (Js.string "Git_Console_http.connect()\n");
    let module T = (val Mimic.repr http_protocol) in
    let edn = Mimic.make ~name:"http-endpoint" in
    let k0 uri = Lwt.return_some uri in
    let k1 git_transmission git_scheme =
      match (git_transmission, git_scheme) with
      | `HTTP (uri, _), (`HTTP | `HTTPS) -> Lwt.return_some uri
      | _ -> Lwt.return_none
    in
    let k2 git_scheme git_uri git_http_headers =
      match git_scheme with
      | `Git | `SSH | `Scheme _ -> Lwt.return_none
      | `HTTP | `HTTPS ->
          let headers =
            ("content-type", "application/x-git-upload-pack-request")
            :: git_http_headers
          in
          let handshake ~uri0 ~uri1 = function
            | T.T flow -> (
                Firebug.console##log
                  (Js.string
                     (F.str
                        "Git_Console_http.connect.k2.handshake \
                         uri0='%s' uri1='%s'\n"
                        (Uri.to_string uri0) (Uri.to_string uri1)));
                let ctx = context Mimic.empty in
                Git_af.get ~ctx ~headers uri0 >>= function
                | Ok (_resp, advertised_refs) ->
                    flow.state <-
                      HTTP.Get
                        { advertised_refs; uri = uri1; headers; ctx };
                    Lwt.return_unit
                | Error _ ->
                    flow.state <- Error;
                    Lwt.return_unit)
            | _ -> Lwt.return_unit
          in
          let git_transmission = `HTTP (git_uri, handshake) in
          Lwt.return_some git_transmission
    in
    let ctx =
      Mimic.fold http_endpoint Mimic.Fun.[ req edn ] ~k:k0 ctx
    in
    let ctx =
      Mimic.fold edn
        Mimic.Fun.
          [ req Smart_git.git_transmission; req Smart_git.git_scheme ]
        ~k:k1 ctx
    in
    let ctx =
      Mimic.fold Smart_git.git_transmission
        Mimic.Fun.
          [
            req Smart_git.git_scheme;
            req Smart_git.git_uri;
            dft Smart_git.git_http_headers List.[];
          ]
        ~k:k2 ctx
    in
    Lwt.return ctx
end

module Config = struct
  open Irmin.Backend.Conf

  let spec = Spec.v "console_js_git"

  module Key = struct
    let reference : Git.Reference.t Irmin.Type.t =
      let of_string str =
        Git.Reference.of_string str |> Result.get_ok
      in
      let to_string r = Git.Reference.to_string r in
      Irmin.Type.(map string) of_string to_string

    let head =
      key ~spec ~doc:"The main branch of the Git repository." "head"
        Irmin.Type.(option reference)
        None

    let bare =
      key ~spec ~doc:"Do not expand the filesystem on the disk."
        "bare" Irmin.Type.bool false

    let level =
      key ~spec ~doc:"The Zlib compression level." "level"
        Irmin.Type.(option int)
        None

    let buffers =
      key ~spec ~doc:"The number of 4K pre-allocated buffers."
        "buffers"
        Irmin.Type.(option int)
        None
  end

  let init ?head ?level ?buffers _root =
    let module C = Irmin.Backend.Conf in
    let config = C.empty spec in

    let config = C.add config Key.head head in
    let config = C.add config Key.level level in
    let config = C.add config Key.buffers buffers in
    C.verify config
end

module S = struct
  module Schema =
    Irmin_git.Schema.Make (Git.Mem.Store) (Irmin.Contents.String)
      (Irmin_git.Branch.Make (Irmin.Branch.String))

  module Sync' = struct
    module GitMemSync = Git.Mem.Sync (Git.Mem.Store)
    include GitMemSync
    (* This is where the fetch and push are broken *)
  end

  module SMaker = Irmin_git.Maker (Git.Mem.Store) (Sync')
  module SMade = SMaker.Make (Schema)
  include SMade

  type endpoint = Mimic.ctx * Smart_git.Endpoint.t

  let remote ?(ctx = Mimic.empty) ?headers uri =
    E
      (Firebug.console##log
         (Js.string (F.str "Nav.S.remote(uri=%s)\n" uri));
       let ( ! ) f a b = f b a in
       match Smart_git.Endpoint.of_string uri with
       | Ok edn ->
           let edn =
             Option.fold ~none:edn
               ~some:(!Smart_git.Endpoint.with_headers_if_http edn)
               headers
           in
           Firebug.console##log
             (Js.string "Nav.S.remote() = (ctx, edn) \n");
           (ctx, edn)
       | Error (`Msg err) -> Fmt.invalid_arg "remote: %s" err)

  module Backend = struct
    include Backend
    module R = Remote

    module Remote = struct
      include R

      type endpoint = Mimic.ctx * Smart_git.Endpoint.t

      let ctx e = fst e
      let edn e = snd e

      let fetch t ?depth endpoint branch =
        Firebug.console##log
          (Js.string "S.Backend.Remote.wrapped_fetch()\n");
        R.fetch t ?depth endpoint branch
    end
  end
end

module Sync = Irmin.Sync.Make (S)

type t = S.tree
type tree = t
type step = S.step
type path = step list

let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree

let test_populate () : t Lwt.t =
  let add p s t = S.Tree.add t p s in
  add [ "hello" ] "world" (S.Tree.empty ())
  >>= add [ "hello"; "daddy" ] "ily"
  >>= add [ "beep"; "beep" ] "motherfucker"

let test_pull () : t Lwt.t =
  (* test_populate ()*)
  Firebug.console##log (Js.string "Nav.test_pull()\n");
  S.Repo.v (Config.init "") >>= fun repo ->
  Firebug.console##log (Js.string "Nav.test_pull(2)\n");
  S.of_branch repo "current" >>= fun t ->
  Firebug.console##log (Js.string "Nav.test_pull(3)\n");
  Git_console_http.connect Mimic.empty >>= fun ctx ->
  Firebug.console##log (Js.string "Nav.test_pull(4)\n");
  let upstream =
    S.remote ~ctx
      ~headers:
        [
          ( "Authorization",
            "Basic \
             Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM="
          );
        ]
      "http://localhost:8080/console/rootstore.git"
  in
  Firebug.console##log (Js.string "Nav.test_pull(5)\n");
  Sync.pull_exn t upstream `Set >>= fun _ ->
  Firebug.console##log (Js.string "Nav.test_pull(6)\n");
  S.tree t
(* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *)