diff --git a/boot_js.ml b/boot_js.ml index 9e6e767..afbb306 100644 --- a/boot_js.ml +++ b/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) = diff --git a/cors_proxy.sh b/cors_proxy.sh new file mode 100755 index 0000000..966f3b1 --- /dev/null +++ b/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 diff --git a/dune b/dune index 0982448..4ca3ef9 100644 --- a/dune +++ b/dune @@ -1,20 +1,29 @@ (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) (modes byte js) - (preprocess (pps js_of_ocaml-ppx)) + (preprocess (pps js_of_ocaml-ppx)) (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 diff --git a/human.ml b/human.ml index 6e02fca..c47c022 100644 --- a/human.ml +++ b/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