lol browser requests github repo via cors proxy (via npm, run with ./cors_proxy.sh) but then stack overflows

boot_js.ml

@@ -2,6 +2,11 @@ open Js_of_ocaml
 open Lwt.Infix
 module NVG = Graphv_webgl
 
+let _ =
+  Logs.set_reporter (Human.Logs_browser.console_reporter ());
+  Logs.set_level (Some Debug);
+  Logs.debug (fun m -> m "hello")
+
 (* This scales the canvas to match the DPI of the window,
    it prevents blurriness when rendering to the canvas *)
 let scale_canvas (canvas : Dom_html.canvasElement Js.t) =

cors_proxy.sh

@@ -0,0 +1,7 @@
+#!/bin/bash
+if [ ! -f /tmp/key.pem ]; then
+  echo Creating key
+  openssl req -newkey rsa:2048 -new -nodes -x509 -days 3650 -keyout /tmp/key.pem -out /tmp/cert.pem -batch
+fi
+
+npx http-server --cors -S -P https://github.com --log-ip -c-1 -C /tmp/cert.pem -K /tmp/key.pem

dune

@@ -1,6 +1,8 @@
 (env
  (dev (flags (:standard -warn-error -A))
-  (js_of_ocaml (flags) (compilation_mode separate))))
+  (js_of_ocaml (flags --no-inline --pretty --source-map-inline --debug-info)
+   (build_runtime_flags --no-inline --pretty --source-map-inline --debug-info)
+   (link_flags --source-map-inline))))
 
 (executable
  (name boot_js)
@@ -10,11 +12,18 @@
  (modules boot_js human)
  (libraries
    fmt
+   logs
    graphv_webgl
    js_of_ocaml-lwt
    digestif.ocaml
    irmin.mem
+   git 
    irmin-git
+   httpaf
+   cohttp
+   cohttp-lwt-jsoo
+   mimic
+   uri
    zed
    gg
 

human.ml

@@ -28,15 +28,397 @@ some options:
 - dig into the toplevel environment and manipulate it, this will also help with things like completion and context help
 
 *)
-
+open Js_of_ocaml
 module F = Fmt
 module NVG = Graphv_webgl
 
+module Logs_browser = struct
+  (* Console reporter *)
+
+  open Jsoo_runtime
+
+  let console_obj = Js.pure_js_expr "console"
+
+  let console : Logs.level -> string -> unit =
+   fun level s ->
+    let meth =
+      match level with
+      | Logs.Error -> "error"
+      | Logs.Warning -> "warn"
+      | Logs.Info -> "info"
+      | Logs.Debug -> "debug"
+      | Logs.App -> "log"
+    in
+    ignore (Js.meth_call console_obj meth [| Js.string s |])
+
+  let ppf, flush =
+    let b = Buffer.create 255 in
+    let flush () =
+      let s = Buffer.contents b in
+      Buffer.clear b;
+      s
+    in
+    (Format.formatter_of_buffer b, flush)
+
+  let console_report _src level ~over k msgf =
+    let k _ =
+      console level (flush ());
+      over ();
+      k ()
+    in
+    msgf @@ fun ?header ?tags fmt ->
+    let _tags = tags in
+    match header with
+    | None -> Format.kfprintf k ppf ("@[" ^^ fmt ^^ "@]@.")
+    | Some h -> Format.kfprintf k ppf ("[%s] @[" ^^ fmt ^^ "@]@.") h
+
+  let console_reporter () = { Logs.report = console_report }
+end
+
+let _ =
+  Logs.set_reporter (Logs_browser.console_reporter ());
+  Logs.set_level (Some Debug);
+  Logs.debug (fun m -> m "hello")
+
+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 = 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 Nav = struct
   open Lwt.Infix
-  module G = Irmin_git.Mem
+
-  module KV = Irmin_git.KV (G) (Git.Mem.Sync (G))
+  module Config = struct
-  module S = KV.Make (Irmin.Contents.String)
+    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 "Nav.S.remote()\n");
+         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
 
@@ -48,11 +430,22 @@ module Nav = struct
     >>= add [ "hello"; "daddy" ] "ily"
     >>= add [ "beep"; "beep" ] "motherfucker"
 
-  let test_pull () : t Lwt.t = test_populate ()
+  let test_pull () : t Lwt.t =
-  (* S.Repo.v (Irmin_git.config "") >>= fun repo ->
+    (* test_populate ()*)
-     S.of_branch repo "master" >>= fun t ->
+    Firebug.console##log (Js.string "Nav.test_pull()\n");
-     let upstream = Irmin.Sync.remote_store (module S) t in
+    S.Repo.v (Config.init "") >>= fun repo ->
-                        Sync.pull_exn t upstream `Set >>= fun _ -> S.tree t *)
+    Firebug.console##log (Js.string "Nav.test_pull(2)\n");
+    S.of_branch repo "main" >>= 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 "https://localhost:8080/mirage/irmin.git"
+    in
+
+    Firebug.console##log (Js.string "Nav.test_pull(5)\n");
+    Sync.fetch_exn t upstream >>= fun _ -> S.tree t
+  (* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *)
 end
 
 module Key = struct