it compiles, now we get "exc during Lwt.async: Not_found"

and content

.config/dune

@@ -0,0 +1,30 @@
+(env
+ (dev (flags (:standard -warn-error -A))))
+
+(library
+ (name init)
+ (libraries
+   js_of_ocaml-compiler js_of_ocaml-tyxml js_of_ocaml-toplevel
+   lwt js_of_ocaml-lwt
+   ;; not used directly
+   graphics
+   js_of_ocaml.deriving
+   react reactiveData
+   str dynlink
+   ocp-indent.lib
+   higlo
+   js_of_ocaml-lwt.graphics
+   js_of_ocaml-ppx
+   uucp
+   httpaf
+   digestif.ocaml
+   checkseum.ocaml
+   irmin.mem
+   git 
+   irmin-git
+   cohttp-lwt-jsoo
+   mimic)
+ (modules init store)
+ (preprocess
+  (pps js_of_ocaml-ppx))
+)

.config/dune-project

@@ -0,0 +1,2 @@
+(lang dune 3.4)
+(name init)

.config/init.ml

@@ -0,0 +1,135 @@
+open Js_of_ocaml
+open Js_of_ocaml_tyxml
+open Lwt
+open Store
+open Tyxml
+module F = Fmt
+
+let by_id s = Dom_html.getElementById s
+
+let by_id_coerce s f =
+  Js.Opt.get
+    (f (Dom_html.getElementById s))
+    (fun () ->
+      Firebug.console##log (F.str "by_id_coerce Not_found");
+      raise Not_found)
+
+let do_by_id s f =
+  try f (Dom_html.getElementById s)
+  with Not_found ->
+    Firebug.console##log (F.str "do_by_id Not_found");
+    ()
+
+let resize ~container ~textbox () =
+  Lwt.pause () >>= fun () ->
+  textbox##.style##.height := Js.string "auto";
+  textbox##.style##.height
+  := Js.string (Printf.sprintf "%dpx" (max 18 textbox##.scrollHeight));
+  container##.scrollTop := container##.scrollHeight;
+  Lwt.return ()
+
+(* TODO replace with Angstrom like httpaf *)
+let headers_of_string_list (sl : string list) : Httpaf.Headers.t =
+  Httpaf.Headers.of_list
+    (List.filter_map
+       (fun s ->
+         Firebug.console##log (F.str "headerparse: %s" s);
+         Option.map
+           (fun i ->
+             ( String.trim (String.sub s 0 i),
+               String.trim
+                 (String.sub s (i + 1) (String.length s - i - 1)) ))
+           (String.index_opt s ':'))
+       sl)
+
+let appendchild ~container html =
+  Dom.appendChild container (Tyxml_js.To_dom.of_a html)
+
+let setup_workspace ~container cstore : unit Lwt.t =
+  let render ~container cstore : unit Lwt.t =
+    let module Headers = Httpaf.Headers in
+    Store.S.Tree.list cstore [] >>= fun csl ->
+    container##.innerHTML := Js.string "";
+    Lwt_list.iter_s
+      (fun (step, tree) ->
+        Firebug.console##log (F.str ".config/workspace/%s" step);
+        (try Store.S.Tree.get tree []
+         with Not_found ->
+           Lwt.return "print_newline \"rootstore:// not found?\";;")
+        >>= fun contents ->
+        let headers =
+          headers_of_string_list (String.split_on_char '\n' contents)
+        in
+        Firebug.console##log
+          (F.str "Headers:\n%a" Headers.pp_hum headers);
+        let uri =
+          Uri.of_string
+            (Option.fold ~none:""
+               ~some:(fun s -> s)
+               (Headers.get headers "path"))
+        in
+        appendchild ~container
+          Tyxml_js.Html.(a [ div [ txt "starting..." ] ]);
+        (* Tyxml.Html.(
+           a
+             ~a:[ a_class [ "window" ] ]
+             [
+               div
+                 ~a:[ a_class [ "status" ] ]
+                 [
+                   txt
+                     (F.str "Name: %s; Path: %a" step Uri.pp_hum uri);
+                 ]
+               ;
+                 div
+                   ~a:[ a_class [ "output" ] ]
+                   [ txt (F.str "%s" contents) ];
+               ;
+             ]);*)
+        Lwt.return_unit)
+      csl
+  in
+  cstore >>= render ~container
+
+let setup_storeview ~container ~textbox ~(storeview : Store.t Lwt.t) :
+    unit =
+  let storeview_container = by_id "toplevel-storeview" in
+  Lwt.async (fun _ ->
+      storeview >>= fun storeview ->
+      Firebug.console##log "setup_storeview";
+      Store.S.Tree.list storeview [] >>= fun all ->
+      ignore
+        (List.fold_left
+           (fun acc tok ->
+             match tok with
+             | step, _tree ->
+                 let a = Tyxml_js.Html.(a [ txt step ]) in
+                 Dom.appendChild storeview_container
+                   (Tyxml_js.To_dom.of_a a);
+                 "")
+           "" all);
+      Lwt.return_unit)
+
+let _ =
+  Lwt.async (fun () ->
+      let container = by_id "toplevel-container" in
+      let textbox : 'a Js.t =
+        by_id_coerce "userinput" Dom_html.CoerceTo.textarea
+      in
+      Store.test_pull () >>= fun (remote, s) ->
+      Store.S.tree s >>= fun root_tree ->
+      let workspace_store =
+        (try
+           Store.S.Tree.find_tree root_tree [ ".config"; "workspace" ]
+         with Not_found ->
+           Firebug.console##log
+             (F.str "rootstore://.config/workspace Not_found");
+           raise Not_found)
+        >>= function
+        | Some t -> Lwt.return t
+        | None -> Lwt.return (Store.S.Tree.empty ())
+      in
+      setup_storeview ~storeview:workspace_store ~container ~textbox;
+      Lwt.return
+        (Lwt.async (fun () ->
+             setup_workspace ~container workspace_store)))

.config/store.ml

@@ -0,0 +1,376 @@
+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 () : (Irmin.remote * Sync.db) 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", F.str "Basic %s" "") ]
+      "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");
+  Lwt.return (upstream, t)
+(* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *)

.config/workspace/Window 1

@@ -0,0 +1,4 @@
+path: file:///init
+derp: tastic
+cool:man
+

.config/workspace/Window 2

@@ -0,0 +1,6 @@
+path: file:///hi
+layout: tiling
+size: 100px 30%
+mode: hello, world!
+
+

.config/workspace/Window 3

@@ -0,0 +1,3 @@
+https://kurt.snieck.us/
+layout: tiling
+order: 3

.gitignore

@@ -0,0 +1 @@
+*~

README

@@ -0,0 +1,5 @@
+Derp
+Derp
+
+This is some stuff.
+

init

@@ -0,0 +1 @@
+init