lol browser requests github repo via cors proxy (via npm, run with ./cors_proxy.sh) but then stack overflows
This commit is contained in:
cqc
@ -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) =
|
||||
|
||||
7
cors_proxy.sh
Executable file
7
cors_proxy.sh
Executable file
@ -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
|
||||
11
dune
11
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
|
||||
|
||||
|
||||
411
human.ml
411
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 S = KV.Make (Irmin.Contents.String)
|
||||
|
||||
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 "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 ()
|
||||
(* S.Repo.v (Irmin_git.config "") >>= fun repo ->
|
||||
S.of_branch repo "master" >>= fun t ->
|
||||
let upstream = Irmin.Sync.remote_store (module S) t in
|
||||
Sync.pull_exn t upstream `Set >>= fun _ -> S.tree t *)
|
||||
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 "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
|
||||
|
||||
Reference in New Issue
Block a user