ogui branch

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/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,4 @@
+*~
+
+*/.merlin
+*/_build

.ocamlformat

@@ -0,0 +1,3 @@
+profile = default
+version = 0.26.2
+no-parse-toplevel-phrases

README

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

init

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