it kinda worked but it's so slow i decided to try lablgtk instead

.gitignore

@@ -1,3 +1,3 @@
 *~
 _build/
-secrets.ml
+gitkey.ml

.ocamlformat

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

b64.ml

@@ -0,0 +1,82 @@
+(*
+ * Copyright (c) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+let default_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+
+let uri_safe_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"
+
+let padding = '='
+
+let of_char ?(alphabet = default_alphabet) x =
+  if x = padding then 0 else String.index alphabet x
+
+let to_char ?(alphabet = default_alphabet) x = alphabet.[x]
+
+let decode ?alphabet input =
+  let length = String.length input in
+  let input =
+    if length mod 4 = 0 then input else input ^ String.make (4 - (length mod 4)) padding
+  in
+  let length = String.length input in
+  let words = length / 4 in
+  let padding =
+    match length with
+    | 0 -> 0
+    | _ when input.[length - 2] = padding -> 2
+    | _ when input.[length - 1] = padding -> 1
+    | _ -> 0
+  in
+  let output = Bytes.make ((words * 3) - padding) '\000' in
+  for i = 0 to words - 1 do
+    let a = of_char ?alphabet input.[(4 * i) + 0]
+    and b = of_char ?alphabet input.[(4 * i) + 1]
+    and c = of_char ?alphabet input.[(4 * i) + 2]
+    and d = of_char ?alphabet input.[(4 * i) + 3] in
+    let n = (a lsl 18) lor (b lsl 12) lor (c lsl 6) lor d in
+    let x = (n lsr 16) land 255 and y = (n lsr 8) land 255 and z = n land 255 in
+    Bytes.set output ((3 * i) + 0) (char_of_int x);
+    if i <> words - 1 || padding < 2 then Bytes.set output ((3 * i) + 1) (char_of_int y);
+    if i <> words - 1 || padding < 1 then Bytes.set output ((3 * i) + 2) (char_of_int z)
+  done;
+  Bytes.unsafe_to_string output
+
+let encode ?(pad = true) ?alphabet input =
+  let length = String.length input in
+  let words = (length + 2) / 3 in
+  (* rounded up *)
+  let padding_len = if length mod 3 = 0 then 0 else 3 - (length mod 3) in
+  let output = Bytes.make (words * 4) '\000' in
+  let get i = if i >= length then 0 else int_of_char input.[i] in
+  for i = 0 to words - 1 do
+    let x = get ((3 * i) + 0) and y = get ((3 * i) + 1) and z = get ((3 * i) + 2) in
+    let n = (x lsl 16) lor (y lsl 8) lor z in
+    let a = (n lsr 18) land 63
+    and b = (n lsr 12) land 63
+    and c = (n lsr 6) land 63
+    and d = n land 63 in
+    Bytes.set output ((4 * i) + 0) (to_char ?alphabet a);
+    Bytes.set output ((4 * i) + 1) (to_char ?alphabet b);
+    Bytes.set output ((4 * i) + 2) (to_char ?alphabet c);
+    Bytes.set output ((4 * i) + 3) (to_char ?alphabet d)
+  done;
+  for i = 1 to padding_len do
+    Bytes.set output (Bytes.length output - i) padding
+  done;
+  if pad
+  then Bytes.unsafe_to_string output
+  else Bytes.sub_string output 0 (Bytes.length output - padding_len)

b64.mli

@@ -0,0 +1,40 @@
+(*
+ * Copyright (c) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.com>
+ * Copyright (c) 2014-2016 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+(** Base64 RFC4648 implementation.
+
+    Base64 is a group of similar binary-to-text encoding schemes that represent binary
+    data in an ASCII string format by translating it into a radix-64 representation. It
+    is specified in RFC 4648. *)
+
+val default_alphabet : string
+(** A 64-character string specifying the regular Base64 alphabet. *)
+
+val uri_safe_alphabet : string
+(** A 64-character string specifying the URI- and filename-safe Base64 alphabet. *)
+
+val decode : ?alphabet:string -> string -> string
+(** [decode s] decodes the string [s] that is encoded in Base64 format. Will leave
+    trailing NULLs on the string, padding it out to a multiple of 3 characters.
+    [alphabet] defaults to {!default_alphabet}.
+    @raise Not_found if [s] is not a valid Base64 string. *)
+
+val encode : ?pad:bool -> ?alphabet:string -> string -> string
+(** [encode s] encodes the string [s] into base64. If [pad] is false, no trailing padding
+    is added. [pad] defaults to [true], and [alphabet] to {!default_alphabet}. *)

colorize.ml

@@ -0,0 +1,39 @@
+open Js_of_ocaml
+open Js_of_ocaml_tyxml
+
+let text ~a_class:cl s = Tyxml_js.Html.(span ~a:[ a_class [ cl ] ] [ txt s ])
+
+let ocaml ~a_class:cl s =
+  let tks = Higlo.Lang.parse ~lang:"ocaml" s in
+  let span' cl (s, _) = Tyxml_js.Html.(span ~a:[ a_class [ cl ] ] [ txt s ]) in
+  let make_span = function
+    | Higlo.Lang.Bcomment s -> span' "comment" s
+    | Higlo.Lang.Constant s -> span' "constant" s
+    | Higlo.Lang.Directive s -> span' "directive" s
+    | Higlo.Lang.Escape s -> span' "escape" s
+    | Higlo.Lang.Id s -> span' "id" s
+    | Higlo.Lang.Keyword (level, s) -> span' (Printf.sprintf "kw%d" level) s
+    | Higlo.Lang.Lcomment s -> span' "comment" s
+    | Higlo.Lang.Numeric s -> span' "numeric" s
+    | Higlo.Lang.String s -> span' "string" s
+    | Higlo.Lang.Symbol (level, s) -> span' (Printf.sprintf "sym%d" level) s
+    | Higlo.Lang.Text s -> span' "text" s
+    | Higlo.Lang.Title (_, s) -> span' "text" s
+  in
+  Tyxml_js.Html.(div ~a:[ a_class [ cl ] ] (List.map make_span tks))
+
+let highlight (`Pos from_) to_ e =
+  let _ =
+    List.fold_left
+      (fun pos e ->
+        match Js.Opt.to_option (Dom_html.CoerceTo.element e) with
+        | None -> pos
+        | Some e ->
+            let size = Js.Opt.case e##.textContent (fun () -> 0) (fun t -> t##.length) in
+            if pos + size > from_ && (to_ = `Last || `Pos pos < to_)
+            then e##.classList##add (Js.string "errorloc");
+            pos + size)
+      0
+      (Dom.list_of_nodeList e##.childNodes)
+  in
+  ()

colorize.mli

@@ -0,0 +1,9 @@
+open Js_of_ocaml
+open Js_of_ocaml_tyxml
+
+val text : a_class:string -> string -> [> Html_types.div_content ] Tyxml_js.Html.elt
+
+val ocaml : a_class:string -> string -> [> Html_types.div_content ] Tyxml_js.Html.elt
+
+val highlight :
+  [ `Pos of int ] -> [ `Last | `Pos of int ] -> Dom_html.element Js.t -> unit

cors_proxy.ml

@@ -0,0 +1,217 @@
+module Format = Stdlib.Format
+module Arg = Stdlib.Arg
+open Lwt.Infix
+open Httpaf
+
+module Server = struct
+  include Httpaf_lwt_unix.Server
+
+  let error_handler ?request:_ error start_response =
+    let response_body = start_response Headers.empty in
+    (match error with
+    | `Exn exn ->
+        Body.write_string response_body (Base.Exn.to_string exn);
+        Body.write_string response_body "\n"
+    | #Status.standard as error ->
+        Body.write_string response_body
+          (Status.default_reason_phrase error));
+    Body.close_writer response_body
+end
+
+let proxy_host = "gitea.departmentofinter.net"
+
+let file_response_headers =
+  [
+    ("accept-ranges", "bytes");
+    ("access-control-allow-origin", "*");
+    ( "access-control-allow-headers",
+      "Origin, X-Requested-With, Content-Type, Accept, Range" );
+    ("cache-control", "no-cache, no-store, must-revalidate");
+    ("etag", "W/\"6861266-5562-2024-02-11T19:05:04.733Z\"");
+    ("content-type", "text/html; charset=UTF-8");
+    ("connection", "close");
+  ]
+
+let proxy_handler reqd : unit =
+  match Reqd.request reqd with
+  | Request.{ meth; headers; target; _ } ->
+      Lwt.async (fun () ->
+          let filename = Fmt.str "./%s" target in
+          if
+            Sys.file_exists
+              filename (* && Sys.is_regular_file filename *)
+          then (
+            let file =
+              Lwt_io.open_file ~flags:[ O_RDONLY ] ~mode:Lwt_io.input
+                filename
+            in
+            let headers = Headers.of_list file_response_headers in
+            Lwt_io.file_length filename >>= fun file_len ->
+            let headers =
+              Headers.add_list headers
+                [ ("content-length", Int64.to_string file_len) ]
+            in
+            Format.printf ">>> Response with File:\nHeaders:\n%s\n %!"
+              (Headers.to_string headers);
+            let response = Response.create ~headers `OK in
+            let response_body =
+              Reqd.respond_with_streaming reqd response
+            in
+            file >>= fun file ->
+            let rec reader () =
+              if
+                Int64.compare
+                  (Int64.sub file_len (Lwt_io.position file))
+                  Int64.zero
+                > 0
+              then (
+                Lwt_io.read file >>= fun s ->
+                Format.printf ".%i\n%!" (String.length s);
+                Body.write_string response_body s;
+
+                reader ())
+              else Lwt.return_unit >>= fun () -> Lwt.return_unit
+            in
+
+            reader () >>= fun () ->
+            Body.close_writer response_body;
+            Lwt_io.close file >>= fun () ->
+            Format.printf "done%!";
+            Lwt.return_unit)
+          else
+            let uri = Fmt.str "https://%s%s" proxy_host target in
+            let proxy_finished, proxy_notify_finished = Lwt.wait () in
+            let proxy_response_handler _
+                (proxy_response_body_acc : Buffer.t)
+                proxy_response_body =
+              Format.printf ">>> proxy_response_body chunk: %i\n%!"
+                (String.length proxy_response_body);
+              Buffer.add_string proxy_response_body_acc
+                proxy_response_body;
+              Lwt.return proxy_response_body_acc
+            in
+            let request_headers =
+              Headers.replace headers "Host" proxy_host
+            in
+            let request_headers =
+              Headers.replace request_headers "origin"
+                (Fmt.str "https://%s" proxy_host)
+            in
+            let request_headers =
+              Headers.replace request_headers "content-type"
+                "application/x-git-upload-pack-request"
+            in
+
+            let proxy_request_headers =
+              Headers.of_list
+                [
+                  ("Accept-Language", "en-US, *;q=0.9");
+                  ("Accept", "application/x-git-upload-pack-result");
+                  ( "Content-Type",
+                    "application/x-git-receive-upload-request" );
+                  ("Accept-Encoding", "deflate, gzip, br, zstd");
+                  ("User-Agent", "git/2.43.0");
+                  ( "Authorization",
+                    "Basic \
+                     Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM="
+                  );
+                  ("Host", "gitea.departmentofinter.net");
+                  ( "Content-Length",
+                    Option.fold ~some:Fun.id ~none:"0"
+                      (Headers.get headers "content-length") );
+                ]
+            in
+
+            let request_body = Reqd.request_body reqd in
+            let request_body_buffer =
+              Bigstringaf.create
+                (Option.fold ~some:int_of_string ~none:4096
+                   (Headers.get headers "content-length"))
+            in
+            let response_body_buffer = Buffer.create 0 in
+            let rec on_read buffer ~off ~len =
+              Bigstringaf.blit buffer ~src_off:off request_body_buffer
+                ~dst_off:off ~len;
+              Body.schedule_read request_body ~on_eof ~on_read
+            and on_eof () = Body.close_reader request_body in
+            Body.schedule_read request_body ~on_eof ~on_read;
+            Format.printf
+              ">>> Proxy Request: Target:%s Headers:\n%s\n%!" target
+              (String.trim (Headers.to_string request_headers));
+            Format.printf ">>> Proxy Request Body length: %i\n%!"
+              (Bigstringaf.length request_body_buffer);
+            Http_lwt_client.request
+              ?config:(Some (`HTTP_1_1 Httpaf.Config.default))
+              ~meth
+              ~headers:(Headers.to_list request_headers)
+              ?body:(Some (Bigstringaf.to_string request_body_buffer))
+              ~follow_redirect:false uri proxy_response_handler
+              response_body_buffer
+            >>= function
+            | Ok
+                ( { version; status; reason; headers },
+                  proxy_response_body_acc ) ->
+                Format.printf
+                  ">>> Response Ok: Code: %i Reason: %s Headers:\n\
+                   %s\n\
+                   %!"
+                  (H2.Status.to_code status)
+                  reason
+                  (String.trim (H2.Headers.to_string headers));
+                let headers =
+                  Headers.of_list (H2.Headers.to_list headers)
+                in
+                let status =
+                  Status.of_code (H2.Status.to_code status)
+                in
+                let response =
+                  let content_type =
+                    match Headers.get headers "content-type" with
+                    | None -> "application/octet-stream"
+                    | Some x -> x
+                  in
+                  Response.create ~reason ~version
+                    ~headers:
+                      (Headers.replace headers "content-type"
+                         content_type)
+                    status
+                in
+                let response_body =
+                  Reqd.respond_with_streaming reqd response
+                in
+                Body.write_string response_body ~off:0
+                  ~len:(Buffer.length proxy_response_body_acc)
+                  (Buffer.contents proxy_response_body_acc);
+                Body.close_writer response_body;
+                Lwt.wakeup_later proxy_notify_finished ();
+                Lwt.return_unit
+            | Error (`Msg msg) ->
+                Format.printf "Request failed with %s%!" msg;
+                Lwt.return_unit >>= fun () -> proxy_finished)
+(* | _ ->
+     let headers = Headers.of_list [ ("connection", "close") ] in
+     Reqd.respond_with_string reqd
+       (Response.create ~headers `Method_not_allowed)
+       "" *)
+
+let request_handler (_ : Unix.sockaddr) = proxy_handler
+let error_handler (_ : Unix.sockaddr) = Server.error_handler
+
+let main port =
+  let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in
+  Lwt.async (fun () ->
+      Lwt_io.establish_server_with_client_socket listen_address
+        (Server.create_connection_handler ~request_handler
+           ~error_handler)
+      >|= fun _server ->
+      Stdio.printf
+        "Listening on localhost:%i and proxying requests via \
+         https://%s.\n\
+         %!"
+        port proxy_host);
+  let forever, _ = Lwt.wait () in
+  Lwt_main.run forever
+
+let () =
+  let port = ref 8080 in
+  main !port

cors_proxy.sh

@@ -0,0 +1,17 @@
+#!/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://gitea.departmentofinter.net --log-ip -c-1 -C /tmp/cert.pem -K /tmp/key.pem
+
+# HTTP/1.1 204 No Content
+# accept-ranges: bytes
+# access-control-allow-origin: *
+# access-control-allow-headers: Origin, X-Requested-With, Content-Type, Accept, Range
+# Date: Tue, 13 Feb 2024 00:42:59 GMT
+# Connection: keep-alive
+# Keep-Alive: timeout=5
+
+#mitmproxy --map-local="|localhost:8080/|$(pwd)" --map-remote="|localhost:8080/console|https://gitea.departmentofinter.#net/console" -H="|Access-Control-Allow-Origin|*" -H "|Access-Control-Allow-Credentials|true" -H "|Access-Control-Allow#-Methods|GET, POST, OPTIONS" -H "|Access-Control-Allow-Headers|*" -H "|Access-Control-Max-Age|86400" -H="|Authorizatio#n|Basic cqc:d9c2b491e70e31a760ce70bc431036c91325f683"

dune

@@ -1,44 +1,160 @@
 (env
  (dev (flags (:standard -warn-error -A))))
 
+(executables
+ (names cors_proxy)
+ (libraries httpaf httpaf-lwt-unix base stdio fmt http-lwt-client)
+ (modules cors_proxy))
+
 (library (name store)
  (libraries
-  fmt
+  digestif.ocaml
-  irmin.unix
+  checkseum.ocaml
-  irmin-git.unix
+  irmin.mem
-  irmin-graphql.unix
+  git 
-  lwt
+  irmin-git
-  lwt.unix
+  cohttp-lwt-jsoo
- )
+  mimic
- (modules store)
+ js_of_ocaml)
-)
+ (modules store gitkey)
-
+ (preprocess
+  (pps js_of_ocaml-ppx)))
 
 (executables
  (names oplevel)
- (modules oplevel secrets perfgraph ogui glfw_types)
  (libraries
-   lwt
   store
-   ;;memtrace
+  js_of_ocaml-compiler js_of_ocaml-tyxml js_of_ocaml-toplevel
-   glfw-ocaml
+  lwt js_of_ocaml-lwt
-   tgls
+  ;; not used directly
-   tgls.tgles2
+  graphics
-   graphv_gles2_native
+  tyxml
-   gg
+  tyxml.functor
-   irmin-git
+  js_of_ocaml.deriving
-   compiler-libs.toplevel
+  react reactiveData
-   re
+  str dynlink
-   lwt_react
+  ocp-indent.lib
- )
+  higlo
+  js_of_ocaml-lwt.graphics
+  js_of_ocaml-ppx
+  js_of_ocaml-compiler.runtime
+  js_of_ocaml-compiler.dynlink
+  uucp
+  httpaf
+  tyxml-ppx
+ tyxml-syntax)
+ (flags
+  (:standard -rectypes -warn-error -A))
+ (link_flags
+  (:standard -linkall -keep-docs -keep-locs ))
+ (modes js byte )
+ (js_of_ocaml
+  (link_flags (:standard))
+  (build_runtime_flags
+   (:standard
+    +toplevel.js
+    +dynlink.js
+    --file
+    %{dep:examples.ml}
+    --file
+    %{dep:test_dynlink.cmo}
+    --file
+    %{dep:test_dynlink.js}
+))
 
- ;; none of this makes backtraces work
+  (flags
- ;;(flags (-g))
+   (:standard
- ;;(link_flags (-linkall -g))
+     --toplevel --linkall --target-env=browser 
- ;;(ocamlopt_flags (:standard -O3 -unboxed-types))
+     (:include effects_flags.sexp)
- ;;(ocamlc_flags (:standard -verbose -g))
+ )))
-
+ (modules
- ;;(modes byte_complete) ;; this causes backtraces to not work, but somehow includes the implementation of Toploop
+  oplevel toplevel ppx_support graphics_support colorize ocp_indent indent b64 )
  (preprocess
-  (pps ppx_irmin))
+  (pps js_of_ocaml-ppx)))
-)
+
+(rule
+ (targets test_dynlink.cmo test_dynlink.cmi)
+ (action
+  (run ocamlc -c %{dep:test_dynlink.ml})))
+
+(rule
+ (targets test_dynlink.js)
+ (action
+  (run %{bin:js_of_ocaml} --pretty --toplevel %{dep:test_dynlink.cmo})))
+
+(rule
+ (targets export.txt)
+ (deps
+  (package js_of_ocaml-ppx)
+  (package js_of_ocaml)
+  (package js_of_ocaml-compiler)
+  (package js_of_ocaml-lwt)
+  (package js_of_ocaml-tyxml)
+  (package js_of_ocaml-toplevel))
+ (action
+  (run
+   jsoo_listunits
+   -o
+   %{targets}
+   stdlib
+   graphics
+   str
+   dynlink
+   js_of_ocaml-compiler.runtime
+   js_of_ocaml-lwt.graphics
+   js_of_ocaml-ppx.as-lib
+   js_of_ocaml.deriving
+   lwt
+   tyxml.functor
+   tyxml.functor:html_types.cmi
+   react
+   reactiveData
+   js_of_ocaml
+   js_of_ocaml-lwt
+   js_of_ocaml-tyxml
+   js_of_ocaml-toplevel)))
+
+(executable
+ (name effects_flags)
+ (modules effects_flags))
+
+(rule
+ (target effects_flags.sexp)
+ (action
+  (with-stdout-to
+   %{target}
+   (run ./effects_flags.exe sexp))))
+
+(rule
+ (target effects_flags.txt)
+ (action
+  (with-stdout-to
+   %{target}
+   (run ./effects_flags.exe txt))))
+
+(rule
+ (targets oplevel.js)
+ (action
+  (run
+   %{bin:js_of_ocaml}
+   compile
+   --pretty
+   %{read-strings:effects_flags.txt}
+   --Werror
+   --target-env
+   browser
+   --file
+   %{dep:examples.ml}
+   --file
+   %{dep:test_dynlink.cmo}
+   --file
+   %{dep:test_dynlink.js}
+    --toplevel
+    --linkall
+   %{dep:oplevel.bc}
+   -o
+   %{targets})))
+
+(alias
+ (name default)
+ (deps  oplevel.bc.js index.html))

dune-project

@@ -1,2 +1,2 @@
-(lang dune 3.15)
+(lang dune 3.4)
 (name oplevel)

effects_flags.ml

@@ -0,0 +1,15 @@
+let enable b n =
+  let f = if b then "--enable" else "--disable" in
+  [ f; n ]
+
+let () =
+  let major = String.split_on_char '.' Sys.ocaml_version |> List.hd |> int_of_string in
+  let has_effect = major >= 5 in
+  let l = enable has_effect "effects" in
+  match Sys.argv |> Array.to_list |> List.tl with
+  | "txt" :: [] -> List.iter print_endline l
+  | "sexp" :: [] ->
+      print_endline "(";
+      List.iter print_endline l;
+      print_endline ")"
+  | _ -> assert false

glfw_types.ml

@@ -1,149 +0,0 @@
-open GLFW
-module F = Fmt
-
-let pp_key : key F.t =
- fun ppf k ->
-  F.pf ppf
-    GLFW.(
-      match k with
-      | Unknown -> "Unknown"
-      | Space -> "Space"
-      | Apostrophe -> "Apostrophe"
-      | Comma -> "Comma"
-      | Minus -> "Minus"
-      | Period -> "Period"
-      | Slash -> "Slash"
-      | Num0 -> "Num0"
-      | Num1 -> "Num1"
-      | Num2 -> "Num2"
-      | Num3 -> "Num3"
-      | Num4 -> "Num4"
-      | Num5 -> "Num5"
-      | Num6 -> "Num6"
-      | Num7 -> "Num7"
-      | Num8 -> "Num8"
-      | Num9 -> "Num9"
-      | Semicolon -> "Semicolon"
-      | Equal -> "Equal"
-      | A -> "A"
-      | B -> "B"
-      | C -> "C"
-      | D -> "D"
-      | E -> "E"
-      | F -> "F"
-      | G -> "G"
-      | H -> "H"
-      | I -> "I"
-      | J -> "J"
-      | K -> "K"
-      | L -> "L"
-      | M -> "M"
-      | N -> "N"
-      | O -> "O"
-      | P -> "P"
-      | Q -> "Q"
-      | R -> "R"
-      | S -> "S"
-      | T -> "T"
-      | U -> "U"
-      | V -> "V"
-      | W -> "W"
-      | X -> "X"
-      | Y -> "Y"
-      | Z -> "Z"
-      | LeftBracket -> "LeftBracket"
-      | Backslash -> "Backslash"
-      | RightBracket -> "RightBracket"
-      | GraveAccent -> "GraveAccent"
-      | World1 -> "World1"
-      | World2 -> "World2"
-      | Escape -> "Escape"
-      | Enter -> "Enter"
-      | Tab -> "Tab"
-      | Backspace -> "Backspace"
-      | Insert -> "Insert"
-      | Delete -> "Delete"
-      | Right -> "Right"
-      | Left -> "Left"
-      | Down -> "Down"
-      | Up -> "Up"
-      | PageUp -> "PageUp"
-      | PageDown -> "PageDown"
-      | Home -> "Home"
-      | End -> "End"
-      | CapsLock -> "CapsLock"
-      | ScrollLock -> "ScrollLock"
-      | NumLock -> "NumLock"
-      | PrintScreen -> "PrintScreen"
-      | Pause -> "Pause"
-      | F1 -> "F1"
-      | F2 -> "F2"
-      | F3 -> "F3"
-      | F4 -> "F4"
-      | F5 -> "F5"
-      | F6 -> "F6"
-      | F7 -> "F7"
-      | F8 -> "F8"
-      | F9 -> "F9"
-      | F10 -> "F10"
-      | F11 -> "F11"
-      | F12 -> "F12"
-      | F13 -> "F13"
-      | F14 -> "F14"
-      | F15 -> "F15"
-      | F16 -> "F16"
-      | F17 -> "F17"
-      | F18 -> "F18"
-      | F19 -> "F19"
-      | F20 -> "F20"
-      | F21 -> "F21"
-      | F22 -> "F22"
-      | F23 -> "F23"
-      | F24 -> "F24"
-      | F25 -> "F25"
-      | Kp0 -> "Kp0"
-      | Kp1 -> "Kp1"
-      | Kp2 -> "Kp2"
-      | Kp3 -> "Kp3"
-      | Kp4 -> "Kp4"
-      | Kp5 -> "Kp5"
-      | Kp6 -> "Kp6"
-      | Kp7 -> "Kp7"
-      | Kp8 -> "Kp8"
-      | Kp9 -> "Kp9"
-      | KpDecimal -> "KpDecimal"
-      | KpDivide -> "KpDivide"
-      | KpMultiply -> "KpMultiply"
-      | KpSubtract -> "KpSubtract"
-      | KpAdd -> "KpAdd"
-      | KpEnter -> "KpEnter"
-      | KpEqual -> "KpEqual"
-      | LeftShift -> "LeftShift"
-      | LeftControl -> "LeftControl"
-      | LeftAlt -> "LeftAlt"
-      | LeftSuper -> "LeftSuper"
-      | RightShift -> "RightShift"
-      | RightControl -> "RightControl"
-      | RightAlt -> "RightAlt"
-      | RightSuper -> "RightSuper"
-      | Menu -> "Menu")
-
-let pp_key_action : GLFW.key_action F.t =
- fun ppf s ->
-  F.pf ppf
-    GLFW.(
-      match s with
-      | Release -> "Release"
-      | Press -> "Press"
-      | Repeat -> "Repeat")
-
-let pp_mods =
-  F.(
-    list (fun ppf s ->
-        pf ppf
-          GLFW.(
-            match s with
-            | Shift -> "Shift"
-            | Control -> "Control"
-            | Alt -> "Alt"
-            | Super -> "Super")))

graphics_support.ml

@@ -0,0 +1 @@
+let init elt = Graphics_js.open_canvas elt

indent.ml

@@ -0,0 +1,43 @@
+open Js_of_ocaml
+
+let textarea (textbox : Dom_html.textAreaElement Js.t) : unit =
+  let rec loop s acc (i, pos') =
+    try
+      let pos = String.index_from s pos' '\n' in
+      loop s ((i, (pos', pos)) :: acc) (succ i, succ pos)
+    with _ -> List.rev ((i, (pos', String.length s)) :: acc)
+  in
+  let rec find (l : (int * (int * int)) list) c =
+    match l with
+    | [] -> assert false
+    | (i, (lo, up)) :: _ when up >= c -> c, i, lo, up
+    | (_, (_lo, _up)) :: rem -> find rem c
+  in
+  let v = textbox##.value in
+  let pos =
+    let c1 = textbox##.selectionStart and c2 = textbox##.selectionEnd in
+    if Js.Opt.test (Js.Opt.return c1) && Js.Opt.test (Js.Opt.return c2)
+    then
+      let l = loop (Js.to_string v) [] (0, 0) in
+      Some (find l c1, find l c2)
+    else None
+  in
+  let f =
+    match pos with
+    | None -> fun _ -> true
+    | Some ((_c1, line1, _lo1, _up1), (_c2, line2, _lo2, _up2)) ->
+        fun l -> l >= line1 + 1 && l <= line2 + 1
+  in
+  let v = Ocp_indent.indent (Js.to_string v) f in
+  textbox##.value := Js.string v;
+  match pos with
+  | Some ((c1, line1, _lo1, up1), (c2, line2, _lo2, up2)) ->
+      let l = loop v [] (0, 0) in
+      let lo1'', up1'' = List.assoc line1 l in
+      let lo2'', up2'' = List.assoc line2 l in
+      let n1 = max (c1 + up1'' - up1) lo1'' in
+      let n2 = max (c2 + up2'' - up2) lo2'' in
+      let () = (Obj.magic textbox)##setSelectionRange n1 n2 in
+      textbox##focus;
+      ()
+  | None -> ()

indent.mli

@@ -0,0 +1,3 @@
+open Js_of_ocaml
+
+val textarea : Dom_html.textAreaElement Js.t -> unit

ocp_indent.ml

@@ -0,0 +1,14 @@
+let _ = Approx_lexer.enable_extension "lwt"
+
+let indent s in_lines =
+  let output =
+    { IndentPrinter.debug = false
+    ; config = IndentConfig.default
+    ; in_lines
+    ; indent_empty = true
+    ; adaptive = true
+    ; kind = IndentPrinter.Print (fun s acc -> acc ^ s)
+    }
+  in
+  let stream = Nstream.of_string s in
+  IndentPrinter.proceed output stream IndentBlock.empty ""

opam_switch

@@ -1,275 +0,0 @@
-opam-version: "2.0"
-compiler: ["ocaml-variants.5.1.1+options"]
-roots: [
-  "camlp5.8.03.00"
-  "gg.1.0.0"
-  "glfw-ocaml.3.3.1-2"
-  "graphv_gles2_native.0.1.1"
-  "irmin-git.3.9.0"
-  "lablgtk3.3.1.4"
-  "lablgtk3-sourceview3.3.1.4"
-  "lwd.0.3"
-  "lwt_glib.1.1.1"
-  "memtrace.0.2.3"
-  "merlin.4.14-501"
-  "ocamlformat.0.26.2"
-  "odig.0.0.9"
-  "stb_image.0.5"
-  "tgls.0.8.6"
-  "tuareg.3.0.1"
-  "user-setup.0.7"
-  "utop.2.14.0"
-]
-installed: [
-  "angstrom.0.16.0"
-  "arp.3.1.1"
-  "asn1-combinators.0.2.6"
-  "astring.0.8.5"
-  "awa.0.3.0"
-  "awa-mirage.0.3.0"
-  "b0.0.0.5"
-  "base.v0.16.3"
-  "base-bigarray.base"
-  "base-bytes.base"
-  "base-domains.base"
-  "base-nnp.base"
-  "base-threads.base"
-  "base-unix.base"
-  "base64.3.5.1"
-  "bheap.2.0.0"
-  "bigarray-compat.1.1.0"
-  "bigstringaf.0.9.1"
-  "biniou.1.2.2"
-  "bos.0.2.1"
-  "ca-certs.0.2.3"
-  "ca-certs-nss.3.98"
-  "cairo2.0.6.4"
-  "camlp-streams.5.0.1"
-  "camlp5.8.03.00"
-  "camlp5-buildscripts.0.03"
-  "carton.0.7.1"
-  "carton-git.0.7.1"
-  "carton-lwt.0.7.1"
-  "cf.0.5.0"
-  "cf-lwt.0.5.0"
-  "checkseum.0.5.2"
-  "cmdliner.1.2.0"
-  "cohttp.5.3.1"
-  "cohttp-lwt.5.3.0"
-  "cohttp-lwt-unix.5.3.0"
-  "conduit.6.2.2"
-  "conduit-lwt.6.2.2"
-  "conduit-lwt-unix.6.2.2"
-  "conf-bash.1"
-  "conf-cairo.1"
-  "conf-emacs.1"
-  "conf-gles2.1"
-  "conf-glfw3.2"
-  "conf-glib-2.1"
-  "conf-gmp.4"
-  "conf-gmp-powm-sec.3"
-  "conf-gtk3.18"
-  "conf-gtksourceview3.0+2"
-  "conf-libffi.2.0.0"
-  "conf-m4.1"
-  "conf-perl.2"
-  "conf-pkg-config.3"
-  "conf-which.1"
-  "cppo.1.6.9"
-  "crunch.3.3.1"
-  "csexp.1.5.2"
-  "cstruct.6.2.0"
-  "cstruct-lwt.6.2.0"
-  "cstruct-unix.6.2.0"
-  "ctypes.0.20.2"
-  "ctypes-foreign.0.18.0"
-  "decompress.1.5.3"
-  "digestif.1.2.0"
-  "dispatch.0.5.0"
-  "dns.7.0.3"
-  "dns-client.7.0.3"
-  "dns-client-lwt.7.0.3"
-  "dns-client-mirage.7.0.3"
-  "domain-name.0.4.0"
-  "dot-merlin-reader.4.9"
-  "duff.0.5"
-  "dune.3.15.2"
-  "dune-build-info.3.15.2"
-  "dune-configurator.3.15.2"
-  "duration.0.2.1"
-  "easy-format.1.3.4"
-  "either.1.0.0"
-  "emile.1.1"
-  "encore.0.8"
-  "eqaf.0.9"
-  "ethernet.3.2.0"
-  "faraday.0.8.2"
-  "fix.20230505"
-  "fmt.0.9.0"
-  "fpath.0.7.3"
-  "fsevents.0.3.0"
-  "fsevents-lwt.0.3.0"
-  "functoria-runtime.4.4.2"
-  "gg.1.0.0"
-  "git.3.15.0"
-  "git-mirage.3.15.0"
-  "git-paf.3.15.0"
-  "git-unix.3.15.0"
-  "glfw-ocaml.3.3.1-2"
-  "gmap.0.3.0"
-  "graphql.0.14.0"
-  "graphql-cohttp.0.14.0"
-  "graphql-lwt.0.14.0"
-  "graphql_parser.0.14.0"
-  "graphv_core.0.1.1"
-  "graphv_core_lib.0.1.1"
-  "graphv_font.0.1.1"
-  "graphv_font_stb_truetype.0.1.1"
-  "graphv_gles2.0.1.1"
-  "graphv_gles2_native.0.1.1"
-  "graphv_gles2_native_impl.0.1.1"
-  "h2.0.11.0"
-  "happy-eyeballs.0.6.0"
-  "happy-eyeballs-lwt.0.6.0"
-  "happy-eyeballs-mirage.0.6.0"
-  "hashcons.1.4.0"
-  "hex.1.5.0"
-  "hkdf.1.0.4"
-  "hpack.0.11.0"
-  "httpaf.0.7.1"
-  "hxd.0.3.2"
-  "index.1.6.2"
-  "inotify.2.5"
-  "integers.0.7.0"
-  "ipaddr.5.5.0"
-  "ipaddr-cstruct.5.5.0"
-  "ipaddr-sexp.5.5.0"
-  "irmin.3.9.0"
-  "irmin-fs.3.9.0"
-  "irmin-git.3.9.0"
-  "irmin-graphql.3.9.0"
-  "irmin-pack.3.9.0"
-  "irmin-tezos.3.9.0"
-  "irmin-watcher.0.5.0"
-  "jsonm.1.0.2"
-  "ke.0.6"
-  "lablgtk3.3.1.4"
-  "lablgtk3-sourceview3.3.1.4"
-  "lambda-term.3.3.2"
-  "logs.0.7.0"
-  "lru.0.3.1"
-  "lwd.0.3"
-  "lwt.5.7.0"
-  "lwt-dllist.1.0.1"
-  "lwt_glib.1.1.1"
-  "lwt_react.1.2.0"
-  "macaddr.5.5.0"
-  "macaddr-cstruct.5.5.0"
-  "magic-mime.1.3.1"
-  "memtrace.0.2.3"
-  "menhir.20231231"
-  "menhirCST.20231231"
-  "menhirLib.20231231"
-  "menhirSdk.20231231"
-  "merlin.4.14-501"
-  "merlin-lib.4.14-501"
-  "metrics.0.4.1"
-  "metrics-lwt.0.4.1"
-  "mew.0.1.0"
-  "mew_vi.0.5.0"
-  "mimic.0.0.6"
-  "mimic-happy-eyeballs.0.0.6"
-  "mirage-clock.4.2.0"
-  "mirage-clock-unix.4.2.0"
-  "mirage-crypto.0.11.3"
-  "mirage-crypto-ec.0.11.3"
-  "mirage-crypto-pk.0.11.3"
-  "mirage-crypto-rng.0.11.3"
-  "mirage-crypto-rng-lwt.0.11.3"
-  "mirage-device.2.0.0"
-  "mirage-flow.3.0.0"
-  "mirage-kv.6.1.1"
-  "mirage-net.4.0.0"
-  "mirage-no-solo5.1"
-  "mirage-random.3.0.0"
-  "mirage-runtime.4.5.1"
-  "mirage-time.3.0.0"
-  "mirage-unix.5.0.1"
-  "mtime.2.0.0"
-  "not-ocamlfind.0.13"
-  "num.1.5"
-  "ocaml.5.1.1"
-  "ocaml-compiler-libs.v0.12.4"
-  "ocaml-config.3"
-  "ocaml-syntax-shims.1.0.0"
-  "ocaml-variants.5.1.1+options"
-  "ocaml-version.3.6.7"
-  "ocamlbuild.0.14.3"
-  "ocamlfind.1.9.6"
-  "ocamlformat.0.26.2"
-  "ocamlformat-lib.0.26.2"
-  "ocamlgraph.2.1.0"
-  "ocp-indent.1.8.1"
-  "ocplib-endian.1.2"
-  "odig.0.0.9"
-  "odoc.2.4.2"
-  "odoc-parser.2.4.2"
-  "optint.0.3.0"
-  "paf.0.5.0"
-  "parsexp.v0.16.0"
-  "pbkdf.1.2.0"
-  "pecu.0.7"
-  "ppx_derivers.1.2.1"
-  "ppx_deriving.5.2.1"
-  "ppx_enumerate.v0.16.0"
-  "ppx_irmin.3.9.0"
-  "ppx_repr.0.7.0"
-  "ppx_sexp_conv.v0.16.0"
-  "ppxlib.0.32.1"
-  "progress.0.4.0"
-  "psq.0.2.1"
-  "ptime.1.1.0"
-  "randomconv.0.1.3"
-  "re.1.11.0"
-  "react.1.2.2"
-  "repr.0.7.0"
-  "result.1.5"
-  "rresult.0.7.0"
-  "rusage.1.0.0"
-  "semaphore-compat.1.0.1"
-  "seq.base"
-  "sexplib.v0.16.0"
-  "sexplib0.v0.16.0"
-  "stb_image.0.5"
-  "stb_truetype.0.7"
-  "stdio.v0.16.0"
-  "stdlib-shims.0.3.0"
-  "stringext.1.6.0"
-  "tcpip.8.0.0"
-  "terminal.0.4.0"
-  "tezos-base58.1.0.0"
-  "tgls.0.8.6"
-  "tls.0.17.3"
-  "tls-lwt.0.17.3"
-  "tls-mirage.0.17.3"
-  "topkg.1.0.7"
-  "trie.1.0.0"
-  "tuareg.3.0.1"
-  "tyxml.4.6.0"
-  "uchar.0.0.2"
-  "uri.4.4.0"
-  "uri-sexp.4.4.0"
-  "user-setup.0.7"
-  "utop.2.14.0"
-  "uucp.15.1.0"
-  "uuseg.15.1.0"
-  "uutf.1.0.3"
-  "vector.1.0.0"
-  "webmachine.0.7.0"
-  "x509.0.16.5"
-  "xdg.3.15.2"
-  "yaml.3.2.0"
-  "yojson.2.1.2"
-  "zarith.1.13"
-  "zed.3.2.3"
-]

oplevel.ml

@@ -1,264 +1,133 @@
-open Lwt.Infix
+open Js_of_ocaml
-module F = Fmt
+open Js_of_ocaml_tyxml
-open Tgles2
+open Lwt
-module Gv = Graphv_gles2_native
+open Store
-open Ogui
 
-module GLFWExtras = struct
+let by_id s = Dom_html.getElementById s
-  open Ctypes
-  open Foreign
 
-  let glfwSetErrorCallback :
+let by_id_coerce s f =
-      (int -> string -> unit) -> int -> string -> unit =
+  Js.Opt.get
-    let errorfun = int @-> string @-> returning void in
+    (f (Dom_html.getElementById s))
-    foreign "glfwSetErrorCallback"
+    (fun () -> raise Not_found)
-      (funptr errorfun @-> returning (funptr errorfun))
-end
 
-let errorcb error desc =
+let resize ~container ~textbox () =
-  Printf.printf "GLFW error %d: %s\n%!" error desc
+  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 ()
 
-let load_fonts vg =
+let appendchild ~container html =
-  let _ = Gv.Text.create vg ~name:"mono" ~file:"./assets/mono.ttf" in
+  Dom.appendChild container (Tyxml_js.To_dom.of_a html)
-  let _ =
-    Gv.Text.create vg ~name:"icons" ~file:"./assets/entypo.ttf"
-  in
-  let _ =
-    Gv.Text.create vg ~name:"sans" ~file:"./assets/Roboto-Regular.ttf"
-  in
-  let _ =
-    Gv.Text.create vg ~name:"sans-bold"
-      ~file:"./assets/Roboto-Bold.ttf"
-  in
-  let _ =
-    Gv.Text.create vg ~name:"emoji"
-      ~file:"./assets/NotoEmoji-Regular.ttf"
-  in
-  Gv.Text.add_fallback vg ~name:"sans" ~fallback:"emoji";
-  Gv.Text.add_fallback vg ~name:"sans-bold" ~fallback:"emoji";
-  Gv.Text.set_font_face vg ~name:"mono"
 
-let main =
+let _ =
-  GLFW.init ();
+  Dom_html.window##.onload
-  at_exit GLFW.terminate;
+  := Dom_html.handler (fun _ ->
-  let _res = GLFWExtras.glfwSetErrorCallback errorcb in
-  GLFW.windowHint ~hint:GLFW.ClientApi ~value:GLFW.OpenGLESApi;
-  GLFW.windowHint ~hint:GLFW.ContextVersionMajor ~value:2;
-  GLFW.windowHint ~hint:GLFW.ContextVersionMinor ~value:0;
-
-  let window =
-    GLFW.createWindow ~width:1000 ~height:600 ~title:"window" ()
-  in
-  (* Make the window's context current *)
-  GLFW.makeContextCurrent ~window:(Some window);
-  GLFW.swapInterval ~interval:0;
-
-  Gl.clear_color 0.1 0.2 0.2 1.;
-
-  (*Memtrace.trace_if_requested (); *)
-  let ctx =
-    Gv.create ~flags:Gv.CreateFlags.(antialias lor stencil_strokes) ()
-  in
-
-  let graph = Perfgraph.init Perfgraph.FPS "Frame Time" in
-  let min_fps = ref Float.max_float in
-  let max_fps = ref Float.min_float in
-
-  let rootrepo =
-    Store.init_default
-      (F.str "%s/console/rootstore.git" Secrets.giturl)
-  in
-
-  let ui =
-    Ogui.Ui.window ctx ~window Gg.(Box2.v P2.o (P2.v 500. 500.))
-  in
-
-  load_fonts ui.gv;
-
-  (* Format.safe_set_geometry ~max_indent:(500 - 1) ~margin:500; *)
-  let event_stream, event_push = Lwt_stream.create () in
-  Ogui.Ui.process_events ui event_stream;
-  GLFW.setKeyCallback ~window
-    ~f:
-      (Some
-         (fun _window key _int state mods ->
-           (* ignore key releases and capslock *)
-           match (state, key, mods) with
-           | Release, _, _ | _, CapsLock, _ -> ()
-           | _ -> event_push (Some (`Key (state, key, mods)))
-           (*Lwt.async (fun () ->
-               Ogui.Ui.keycallback ui state key mods >>= fun _ ->
-               Lwt.return_unit) *)))
-  |> ignore;
-
-  GLFW.setCharCallback ~window
-    ~f:
-      (Some
-         (fun _window ch ->
-           event_push (Some (`Char ch))
-           (* Lwt.async (fun () -> Ogui.Ui.chrcallback ui ch) *)))
-  |> ignore;
-
-  GLFW.setWindowSizeCallback ~window
-    ~f:
-      (Some
-         Gg.(
-           fun _window x y ->
-             Lwd.set ui.rect
-               (Box2.v V2.zero (V2.v (float x) (float y)))))
-  |> ignore;
-
-  F.pr "oplevel.ml: building initial page@.";
-  let initial_path = [ ".config"; "init.ml" ] in
-  TextBuffer.of_repo ~initial_path ~repo:rootrepo >>= fun tb_init ->
-  TextBuffer.of_string ~repo:rootrepo
-    ~path:
-      (List.fold_right
-         (fun a (acc : string list) ->
-           match acc with
-           | [] -> [ F.str "%s.output" a ]
-           | a' -> a :: a')
-         [] initial_path)
-    (F.str "(* --- output:%s --- *)\n\n"
-       (String.concat "/" initial_path))
-  |> Lwt.return
-  >>= fun to_init ->
-  let _out_ppf =
-    let insert s =
          Lwt.async (fun () ->
-          TextBuffer.length to_init >>= fun len ->
+             let output = by_id "output" in
-          (* TKTK if buffer is modified here during yield from >>= it could be weird *)
+             let container = by_id "toplevel-container" in
-          TextBuffer.insert to_init len s)
+             appendchild ~container
-    in
+               Tyxml_js.Html.(
-    Format.formatter_of_out_functions
+                 a
-      Format.
+                   ~a:[ a_class [ "window" ] ]
-        {
-          out_string = (fun s _ _ -> insert s);
-          out_flush = (fun () -> ());
-          out_indent = (fun n -> insert (String.make (n * 2) ' '));
-          out_newline = (fun () -> insert "\n");
-          out_spaces = (fun n -> insert (String.make n ' '));
-        }
-  in
-
-  (*F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
-    Toploop.initialize_toplevel_env ();
-    Clflags.debug := true;
-    ignore
-      (Toploop.use_input out_ppf
-         (String "#use \"topfind\";;\n#list;;#require \"lwt\";;")); *)
-  (* toplevel execution binding *)
-  Ui.(
-    append_bindings ui
-      (Lwd.return
-         Event.
                    [
-             pack Fun.id
+                     div
-               (empty
+                       ~a:[ a_class [ "status" ] ]
-               |> adds
+                       [ txt "starting..." ];
-                    [
-                      [
-                        Key (Press, X, [ Control ]);
-                        Key (Press, E, [ Control ]);
-                      ];
-                    ]
-                    [
-                      Custom
-                        ( "toplevel_execute",
-                          fun () ->
-                            TextBuffer.peek tb_init >>= fun _str ->
-                            (*Toploop.use_input out_ppf (String str)
-                              |> F.epr "Toploop.use_input=%b@."; *)
-                            Lwt.return_unit );
                    ]);
-           ]));
+             let textbox : 'a Js.t =
-
+               by_id_coerce "code" Dom_html.CoerceTo.textarea
-  WindowManager.make ui
-    (Lwd.var
-       (`T
-         ( `Y,
-           WindowManager.
-             [
-               {
-                 t = `TextEdit (TextEdit.multiline ui to_init);
-                 dim = `Ratio 0.333;
-                 bindings = [];
-               };
-               {
-                 t = `TextEdit (TextEdit.multiline ui tb_init);
-                 dim = `Ratio 0.5;
-                 bindings = [];
-               };
-               {
-                 t = `TextEdit (TextEdit.multiline ui to_init);
-                 dim = `Ratio 1.0;
-                 bindings = [];
-               };
-             ] )))
-  >>= fun page ->
-  let page_root = Lwd.observe page in
-
-  let bindings = ui.bindings |> Lwd.observe |> Lwd.quick_sample in
-  F.epr "Bindings:@.";
-  List.iter (fun bs -> F.epr "%a" Ui.pp_pack bs) bindings;
-
-  F.pr "oplevel.ml: entering drawing loop@.";
-  let period_min = 1.0 /. 30. in
-  let t = GLFW.getTime () |> ref in
-
-  let rec draw_loop () =
-    let now = GLFW.getTime () in
-    let dt = now -. !t in
-    t := now;
-
-    Perfgraph.update graph dt;
-
-    if now > 2. then (
-      let avg = 1. /. Perfgraph.average graph in
-      min_fps := Float.min avg !min_fps;
-      max_fps := Float.max avg !max_fps);
-
-    let win_w, win_h = GLFW.getWindowSize ~window in
-    Gl.viewport 0 0 win_w win_h;
-    Gl.clear
-      (Gl.color_buffer_bit lor Gl.depth_buffer_bit
-     lor Gl.stencil_buffer_bit);
-    Gl.enable Gl.blend;
-    Gl.blend_func Gl.src_alpha Gl.one_minus_src_alpha;
-    Gl.enable Gl.cull_face_enum;
-    Gl.disable Gl.depth_test;
-    let page = Lwd.quick_sample page_root in
-    let win_w, win_h = GLFW.getWindowSize ~window in
-    let width, height = (float win_w, float win_h) in
-    let box = Gg.(Box2.v V2.zero Size2.(v width (height -. 20.))) in
-    Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
-    Perfgraph.render graph ctx (width -. 205.) 5.;
-    (*F.epr "Painter.layout=%a@." Gg.Box2.pp box; *)
-    Painter.layout box ui page >>= fun _ ->
-    (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
-    Gv.end_frame ctx;
-    Gc.major_slice 0 |> ignore;
-    GLFW.swapBuffers ~window;
-    GLFW.pollEvents ();
-    Lwt_unix.sleep
-      Float.(max 0. (period_min -. GLFW.getTime () +. !t))
-    >>= fun () ->
-    if not GLFW.(windowShouldClose ~window) then draw_loop ()
-    else Lwt.return_unit
              in
-  (try draw_loop ()
+             let rootrepo = Store.test_pull () in
-   with e ->
+             rootrepo >>= fun (_upstream, t) ->
-     F.epr "draw_loop Exception: %s@.Backtrace:@.%s@."
+             Store.S.tree t >>= fun rootstore ->
-       (Printexc.to_string e)
+             (try
-       (Printexc.get_backtrace ())
+                Store.S.Tree.get rootstore [ ".config"; "init.ml" ]
-     |> Lwt.return)
+              with
-  >>= fun () ->
+             | Not_found | Invalid_argument _ ->
-  Printf.printf "MIN %.2f\n" !min_fps;
+                 Lwt.return
-  Printf.printf "MAX %.2f\n%!" !max_fps;
+                   "print_newline \"rootstore://.config/init.ml not \
-  Lwt.return_unit
+                    found\";;"
+             | exc ->
+                 Firebug.console##log_3
+                   (Js.string ".config/init.ml load exception")
+                   (Js.string (Printexc.to_string exc))
+                   exc;
+                 Lwt.return ";;")
+             >>= fun init ->
+             let execute = ref (Toplevel.run ~init ~output ()) in
+             let meta e =
+               let b = Js.to_bool in
+               b e##.ctrlKey || b e##.altKey || b e##.metaKey
+             in
+             let shift e = Js.to_bool e##.shiftKey in
+             (* setup handlers *)
+             textbox##.onkeyup :=
+               Dom_html.handler (fun _ ->
+                   (* Lwt.async (resize ~container ~textbox); *)
+                   Js._true);
+             textbox##.onchange :=
+               Dom_html.handler (fun _ ->
+                   (* Lwt.async (resize ~container ~textbox); *)
+                   Js._true);
+             textbox##.onkeydown :=
+               Dom_html.handler
+                 Dom_html.Keyboard_code.(
+                   fun e ->
+                     match of_key_code e##.keyCode with
+                     | Enter when not (meta e || shift e) ->
+                         Lwt.async (fun () ->
+                             !execute
+                               (Js.to_string textbox##.value##trim)
+                               ());
+                         Js._false
+                     | Enter ->
+                         Lwt.async (resize ~container ~textbox);
+                         Js._true
+                     | Tab ->
+                         Indent.textarea textbox;
+                         Js._false
+                     | KeyL when meta e ->
+                         output##.innerHTML := Js.string "";
+                         Js._true
+                     | KeyK when meta e ->
+                         Lwt.async
+                           Store.S.(
+                             fun () ->
+                               rootrepo >>= fun (upstream, t) ->
+                               Sync.pull_exn t upstream `Set
+                               >>= fun _ ->
+                               Firebug.console##log
+                                 (Js.string
+                                    "re-pulling rootstore for init.ml\n");
+                               tree t >>= fun rs ->
+                               (try
+                                  Store.S.Tree.get rs
+                                    [ ".config"; "init.ml" ]
+                                with
+                               | Not_found | Invalid_argument _ ->
+                                   Lwt.return
+                                     "print_newline \
+                                      \"rootstore://.config/init.ml \
+                                      not found\";;"
+                               | exc ->
+                                   Firebug.console##log_3
+                                     (Js.string
+                                        ".config/init.ml load \
+                                         exception")
+                                     (Js.string
+                                        (Printexc.to_string exc))
+                                     exc;
+                                   Lwt.return ";;")
+                               >>= fun init ->
+                               Lwt.return
+                                 (execute :=
+                                    Toplevel.run ~init ~output ()));
+                         Js._false
+                     (* | ArrowUp -> history_up e
+                        | ArrowDown -> history_down e *)
+                     | _ -> Js._true);
+             Lwt.return_unit);
 
-let () =
+         Js._false)
-  try Lwt_main.run main
-  with e ->
-    F.epr "Exception: %s@.Backtrace:@.%s@." (Printexc.to_string e)
-      (Printexc.get_backtrace ())

perfgraph.ml

@@ -1,87 +0,0 @@
-module NVG = Graphv_gles2_native
-
-type style = FPS | Ms | Percent
-
-type t = {
-  style : style;
-  name : string;
-  values : float array;
-  mutable head : int;
-  mutable last : float;
-}
-
-let init style name =
-  { name; style; values = Array.make 100 0.; head = 0; last = 0. }
-
-let average t =
-  let avg = ref 0. in
-  for i = 0 to Array.length t.values - 1 do
-    avg := !avg +. t.values.(i)
-  done;
-  !avg /. float (Array.length t.values)
-
-let update t dt =
-  t.head <- (t.head + 1) mod Array.length t.values;
-  t.values.(t.head) <- dt
-(*
-    t.last <- t.last +. dt;
-    if t.last > 1. then (
-        t.last <- 0.;
-        Printf.printf "FPS %.2f\n%!" (1. /. average t);
-    )
-    *)
-
-let render t (vg : NVG.t) x y =
-  let avg = average t in
-  let w = 200. in
-  let h = 35. in
-
-  let open NVG in
-  let open FloatOps in
-  Path.begin_ vg;
-  Path.rect vg ~x ~y ~w ~h;
-  set_fill_color vg ~color:(Color.rgba ~r:0 ~g:0 ~b:0 ~a:128);
-  fill vg;
-
-  Path.begin_ vg;
-  Path.move_to vg ~x ~y:(y + h);
-  let len = Array.length t.values in
-  (match t.style with
-  | FPS ->
-      for i = 0 to len -. 1 do
-        let v = 1. / (0.00001 + t.values.((t.head +. i) mod len)) in
-        let v = if v > 80. then 80. else v in
-        let vx = x + (float i / (float len - 1.) * w) in
-        let vy = y + h - (v / 80. * h) in
-        Path.line_to vg ~x:vx ~y:vy
-      done
-  | Percent -> ()
-  | Ms -> ());
-  Path.line_to vg ~x:(x + w) ~y:(y + h);
-  set_fill_color vg ~color:(Color.rgba ~r:255 ~g:192 ~b:0 ~a:128);
-  fill vg;
-
-  Text.set_font_face vg ~name:"mono";
-
-  Text.set_size vg ~size:12.;
-  Text.set_align vg ~align:Align.(left lor top);
-  set_fill_color vg ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:192);
-  Text.text vg ~x:(x + 3.) ~y:(y + 3.) t.name;
-
-  match t.style with
-  | FPS ->
-      Text.set_size vg ~size:15.;
-      Text.set_align vg ~align:Align.(right lor top);
-      set_fill_color vg
-        ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:255);
-      let s = Printf.sprintf "%.2f FPS" (1. / avg) in
-      Text.text vg ~x:(x + w - 3.) ~y:(y + 3.) s;
-
-      Text.set_size vg ~size:13.;
-      Text.set_align vg ~align:Align.(right lor baseline);
-      set_fill_color vg
-        ~color:(Color.rgba ~r:240 ~g:240 ~b:240 ~a:160);
-      let s = Printf.sprintf "%.2f ms" (avg * 1000.) in
-      Text.text vg ~x:(x + w - 3.) ~y:(y + h - 3.) s
-  | Percent -> ()
-  | Ms -> ()

ppx_support.ml

@@ -0,0 +1 @@
+let init () = Ast_mapper.register "js_of_ocaml" (fun _ -> Ppx_js.mapper)

store.ml

@@ -1,6 +1,345 @@
+open Js_of_ocaml
 open Lwt.Infix
 module F = Fmt
-module S = Irmin_git_unix.FS.KV (Irmin.Contents.String)
+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
@@ -9,7 +348,6 @@ type step = S.step
 type path = step list
 
 let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
-let info = Irmin_git_unix.info
 
 let test_populate () : t Lwt.t =
   let add p s t = S.Tree.add t p s in
@@ -17,13 +355,22 @@ let test_populate () : t Lwt.t =
   >>= add [ "hello"; "daddy" ] "ily"
   >>= add [ "beep"; "beep" ] "motherfucker"
 
-let init_default upstream_url : Sync.db Lwt.t =
+let test_pull () : (Irmin.remote * Sync.db) Lwt.t =
-  S.Repo.v (Irmin_git.Conf.init "../rootstore") >>= fun repo ->
+  (* test_populate ()*)
-  S.of_branch repo "ogui" >>= fun t ->
+  Firebug.console##log (Js.string "Nav.test_pull()\n");
-  S.remote upstream_url >>= fun upstream ->
+  S.Repo.v (Config.init "") >>= fun repo ->
-  (* (try Sync.pull_exn t upstream `Set >>= fun _ -> Lwt.return_unit
+  Firebug.console##log (Js.string "Nav.test_pull(2)\n");
-      with Invalid_argument a ->
+  S.of_branch repo "current" >>= fun t ->
-        F.epr "Sync.pull_exn raised Invalid_argument(%s)" a;
+  Firebug.console##log (Js.string "Nav.test_pull(3)\n");
-        Lwt.return_unit)
+  Git_console_http.connect Mimic.empty >>= fun ctx ->
-     >>= fun () -> *)
+  Firebug.console##log (Js.string "Nav.test_pull(4)\n");
-  Lwt.return t
+  let upstream =
+    S.remote ~ctx
+      ~headers:[ ("Authorization", F.str "Basic %s" Gitkey.key) ]
+      "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 *)

test_dynlink.ml

@@ -0,0 +1,3 @@
+let _ = print_endline "Dynlink OK"
+
+let f () = print_endline "Test_dynlink.f Ok"

toplevel.ml

@@ -225,75 +225,13 @@ let rec iter_on_sharp ~f x =
   | None -> ()
   | Some n -> iter_on_sharp ~f n
 
-let setup_share_button ~output =
+let setup_run_button ~execute =
-  do_by_id "btn-share" (fun e ->
+  do_by_id "btn-run" (fun e ->
       e##.style##.display := Js.string "block";
       e##.onclick :=
         Dom_html.handler (fun _ ->
-            (* get all ocaml code *)
+            let textbox = by_id "code" in
-            let code = ref [] in
+            execute (Js.to_string textbox##.innerText##trim);
-            Js.Opt.iter output##.firstChild
-              (iter_on_sharp ~f:(fun e ->
-                   code :=
-                     Js.Opt.case e##.textContent
-                       (fun () -> "")
-                       Js.to_string
-                     :: !code));
-            let code_encoded =
-              B64.encode (String.concat "" (List.rev !code))
-            in
-            let url, is_file =
-              match Url.Current.get () with
-              | Some (Url.Http url) ->
-                  (Url.Http { url with Url.hu_fragment = "" }, false)
-              | Some (Url.Https url) ->
-                  (Url.Https { url with Url.hu_fragment = "" }, false)
-              | Some (Url.File url) ->
-                  (Url.File { url with Url.fu_fragment = "" }, true)
-              | _ -> assert false
-            in
-            let frag =
-              let frags = parse_hash () in
-              let frags =
-                List.remove_assoc "code" frags
-                @ [ ("code", code_encoded) ]
-              in
-              Url.encode_arguments frags
-            in
-            let uri = Url.string_of_url url ^ "#" ^ frag in
-            let append_url str =
-              let dom =
-                Tyxml_js.Html.(
-                  p
-                    [
-                      txt "Share this url : ";
-                      a ~a:[ a_href str ] [ txt str ];
-                    ])
-              in
-              Dom.appendChild output (Tyxml_js.To_dom.of_element dom)
-            in
-            Lwt.async (fun () ->
-                Lwt.catch
-                  (fun () ->
-                    if is_file then
-                      failwith "Cannot shorten url with file scheme"
-                    else
-                      let uri =
-                        Printf.sprintf
-                          "http://is.gd/create.php?format=json&url=%s"
-                          (Url.urlencode uri)
-                      in
-                      Lwt.bind (Js_of_ocaml_lwt.Jsonp.call uri)
-                        (fun o ->
-                          let str = Js.to_string o##.shorturl in
-                          append_url str;
-                          Lwt.return_unit))
-                  (fun exn ->
-                    Format.eprintf
-                      "Could not generate short url. reason: %s@."
-                      (Printexc.to_string exn);
-                    append_url uri;
-                    Lwt.return_unit));
             Js._false))
 
 let setup_js_preview () =
@@ -383,7 +321,7 @@ let run ~init ~output () :
 
   let container = by_id "toplevel-container" in
   let textbox : 'a Js.t =
-    by_id_coerce "userinput" Dom_html.CoerceTo.textarea
+    by_id_coerce "code" Dom_html.CoerceTo.textarea
   in
   let sharp_chan = open_out "/dev/null0" in
   let sharp_ppf = Format.formatter_of_out_channel sharp_chan in
@@ -402,7 +340,6 @@ let run ~init ~output () :
       else content
     in
     current_position := output##.childNodes##.length;
-    textbox##.value := Js.string "";
     History.push content;
     JsooTop.execute true ~pp_code ~highlight_location caml_ppf
       content';
@@ -443,7 +380,7 @@ let run ~init ~output () :
       (fun s -> Js.to_string s ^ "\n")
   in
   Sys_js.set_channel_filler stdin readline;
-  setup_share_button ~output;
+  setup_run_button ~execute;
   (* setup_examples ~container ~textbox; *)
   setup_pseudo_fs ~load_cmis_from_server:false;
   setup_toplevel ();