From 68828973cb471415a765311c666eadfe7f21a952 Mon Sep 17 00:00:00 2001 From: cqc Date: Tue, 2 Apr 2024 19:18:40 -0500 Subject: [PATCH] it worked but we couldn't figure out how to do the fucking keyboard shortcuts without patching lablgtk3 and understanding a whole bunch of c interface stuff --- .gitignore | 2 +- b64.ml | 82 ---------- b64.mli | 40 ----- colorize.ml | 39 ----- colorize.mli | 9 -- cors_proxy.ml | 217 -------------------------- cors_proxy.sh | 17 -- dune | 172 +++------------------ effects_flags.ml | 15 -- graphics_support.ml | 1 - indent.ml | 43 ------ indent.mli | 3 - index.html | 188 ----------------------- ocp_indent.ml | 14 -- oplevel.ml | 320 +++++++++++++++++++++++--------------- ppx_support.ml | 1 - store.ml | 366 +------------------------------------------- test_dynlink.ml | 3 - 18 files changed, 224 insertions(+), 1308 deletions(-) delete mode 100644 b64.ml delete mode 100644 b64.mli delete mode 100644 colorize.ml delete mode 100644 colorize.mli delete mode 100644 cors_proxy.ml delete mode 100755 cors_proxy.sh delete mode 100644 effects_flags.ml delete mode 100644 graphics_support.ml delete mode 100644 indent.ml delete mode 100644 indent.mli delete mode 100644 index.html delete mode 100644 ocp_indent.ml delete mode 100644 ppx_support.ml delete mode 100644 test_dynlink.ml diff --git a/.gitignore b/.gitignore index be61ab8..27359f7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,3 @@ *~ _build/ -gitkey.ml +secrets.ml diff --git a/b64.ml b/b64.ml deleted file mode 100644 index 5350ace..0000000 --- a/b64.ml +++ /dev/null @@ -1,82 +0,0 @@ -(* - * Copyright (c) 2006-2009 Citrix Systems Inc. - * Copyright (c) 2010 Thomas Gazagnaire - * - * 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) diff --git a/b64.mli b/b64.mli deleted file mode 100644 index 5210809..0000000 --- a/b64.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* - * Copyright (c) 2006-2009 Citrix Systems Inc. - * Copyright (c) 2010 Thomas Gazagnaire - * Copyright (c) 2014-2016 Anil Madhavapeddy - * - * 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}. *) diff --git a/colorize.ml b/colorize.ml deleted file mode 100644 index 09eccea..0000000 --- a/colorize.ml +++ /dev/null @@ -1,39 +0,0 @@ -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 - () diff --git a/colorize.mli b/colorize.mli deleted file mode 100644 index b274e9b..0000000 --- a/colorize.mli +++ /dev/null @@ -1,9 +0,0 @@ -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 diff --git a/cors_proxy.ml b/cors_proxy.ml deleted file mode 100644 index 66a3da2..0000000 --- a/cors_proxy.ml +++ /dev/null @@ -1,217 +0,0 @@ -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 diff --git a/cors_proxy.sh b/cors_proxy.sh deleted file mode 100755 index fecb652..0000000 --- a/cors_proxy.sh +++ /dev/null @@ -1,17 +0,0 @@ -#!/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" diff --git a/dune b/dune index 3b7aebb..5d41d03 100644 --- a/dune +++ b/dune @@ -1,160 +1,32 @@ (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 - digestif.ocaml - checkseum.ocaml - irmin.mem - git - irmin-git - cohttp-lwt-jsoo - mimic - js_of_ocaml) - (modules store gitkey) - (preprocess - (pps js_of_ocaml-ppx))) + fmt + irmin.unix + irmin-git.unix + irmin-graphql.unix + lwt + lwt.unix + ) + (modules store) +) (executables (names oplevel) + (modules oplevel secrets) (libraries - store - js_of_ocaml-compiler js_of_ocaml-tyxml js_of_ocaml-toplevel - lwt js_of_ocaml-lwt - ;; not used directly - graphics - tyxml - tyxml.functor - js_of_ocaml.deriving - react reactiveData - str dynlink - 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} -)) - - (flags - (:standard - --toplevel --linkall --target-env=browser - (:include effects_flags.sexp) - ))) - (modules - oplevel toplevel ppx_support graphics_support colorize ocp_indent indent b64 ) - (preprocess - (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)) + store + lablgtk3 + lablgtk3-sourceview3 + lwt_glib + irmin-git + compiler-libs.toplevel + ) + (link_flags (-linkall)) + (modes byte) + (preprocess + (pps ppx_irmin)) +) diff --git a/effects_flags.ml b/effects_flags.ml deleted file mode 100644 index 4bbf57d..0000000 --- a/effects_flags.ml +++ /dev/null @@ -1,15 +0,0 @@ -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 diff --git a/graphics_support.ml b/graphics_support.ml deleted file mode 100644 index 331e98c..0000000 --- a/graphics_support.ml +++ /dev/null @@ -1 +0,0 @@ -let init elt = Graphics_js.open_canvas elt diff --git a/indent.ml b/indent.ml deleted file mode 100644 index 469907f..0000000 --- a/indent.ml +++ /dev/null @@ -1,43 +0,0 @@ -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 -> () diff --git a/indent.mli b/indent.mli deleted file mode 100644 index 6a8532b..0000000 --- a/indent.mli +++ /dev/null @@ -1,3 +0,0 @@ -open Js_of_ocaml - -val textarea : Dom_html.textAreaElement Js.t -> unit diff --git a/index.html b/index.html deleted file mode 100644 index be9e687..0000000 --- a/index.html +++ /dev/null @@ -1,188 +0,0 @@ - - - - - OCaml toplevel - - - - - - - -
- 

-      

-        

-        
-        
-      

-    

-    

-      
OpLevel

-      
A programming system based on a compiler from OCaml bytecode to Javascript.

-      

-      
-      
See the generated javascript code

-      
-      

-    

-  
-
diff --git a/ocp_indent.ml b/ocp_indent.ml
deleted file mode 100644
index d2a23f6..0000000
--- a/ocp_indent.ml
+++ /dev/null
@@ -1,14 +0,0 @@
-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 ""
diff --git a/oplevel.ml b/oplevel.ml
index e11a0a7..6f6531e 100644
--- a/oplevel.ml
+++ b/oplevel.ml
@@ -1,133 +1,201 @@
-open Js_of_ocaml
-open Js_of_ocaml_tyxml
-open Lwt
-open Store
+open Lwt.Infix
+module F = Fmt
 
-let by_id s = Dom_html.getElementById s
+let lang_mime_type = "text/x-ocaml"
+let lang_name = "ocaml"
+let use_mime_type = true
+let font_name = "Monospace 12"
 
-let by_id_coerce s f =
-  Js.Opt.get
-    (f (Dom_html.getElementById s))
-    (fun () -> raise Not_found)
+let () =
+  Lwt_main.run
+    ((* Initializes GTK. *)
+     ignore (GMain.init ());
 
-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 ()
+     (* Install Lwt<->Glib integration. *)
+     Lwt_glib.install ();
 
-let appendchild ~container html =
-  Dom.appendChild container (Tyxml_js.To_dom.of_a html)
+     (* Thread which is wakeup when the main window is closed. *)
+     let waiter, wakener = Lwt.wait () in
 
-let _ =
-  Dom_html.window##.onload
-  := Dom_html.handler (fun _ ->
-         Lwt.async (fun () ->
-             let output = by_id "output" in
-             let container = by_id "toplevel-container" in
-             appendchild ~container
-               Tyxml_js.Html.(
-                 a
-                   ~a:[ a_class [ "window" ] ]
-                   [
-                     div
-                       ~a:[ a_class [ "status" ] ]
-                       [ txt "starting..." ];
-                   ]);
-             let textbox : 'a Js.t =
-               by_id_coerce "userinput" Dom_html.CoerceTo.textarea
+     let language_manager =
+       GSourceView3.source_language_manager ~default:true
+     in
+
+     let lang =
+       if use_mime_type then
+         match
+           language_manager#guess_language
+             ~content_type:lang_mime_type ()
+         with
+         | Some x -> x
+         | None ->
+             failwith (F.str "no language for %s" lang_mime_type)
+       else
+         match language_manager#language lang_name with
+         | Some x -> x
+         | None -> failwith (F.str "can't load %s" lang_name)
+     in
+     Store.init_default
+       (F.str "%s/console/rootstore.git" Secrets.giturl)
+     >>= fun t ->
+     Store.S.tree t >>= fun rootstore ->
+     (try Store.S.Tree.get rootstore [ ".config"; "init.ml" ] with
+     | Not_found | Invalid_argument _ ->
+         Lwt.return
+           "print_newline \"rootstore://.config/init.ml not found\";;"
+     | exc ->
+         Lwt.return
+           (F.str ".config/init.ml load exception: %s"
+              (Printexc.to_string exc)))
+     >>= fun text ->
+     let source_buffer =
+       GSourceView3.source_buffer ~language:lang ~text
+         ?style_scheme:
+           ((GSourceView3.source_style_scheme_manager ~default:true)
+              #style_scheme "solarized-dark")
+         ~highlight_matching_brackets:true ~highlight_syntax:true ()
+     in
+
+     let win = GWindow.window ~title:"oplevel main" () in
+     (* Quit when the window is closed. *)
+     ignore (win#connect#destroy ~callback:(Lwt.wakeup wakener));
+     (* Show the window. *)
+     win#show ();
+
+     let vbox =
+       GPack.vbox ~spacing:10 ~border_width:15 ~packing:win#add ()
+     in
+     let scroll_edit =
+       GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
+         ~packing:vbox#add ()
+     in
+     let edit =
+       GSourceView3.source_view ~source_buffer ~auto_indent:true
+         ~insert_spaces_instead_of_tabs:true ~tab_width:2
+         ~show_line_numbers:true ~right_margin_position:80
+         ~show_right_margin:true (* ~smart_home_end:true *)
+         ~packing:scroll_edit#add ~height:500 ~width:650 ()
+     in
+     edit#misc#modify_font_by_name font_name;
+     edit#set_smart_home_end `AFTER;
+     if edit#smart_home_end <> `AFTER then failwith "regret";
+     ignore
+       (edit#connect#undo ~callback:(fun _ -> prerr_endline "undo"));
+
+     let scroll_output =
+       GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
+         ~packing:vbox#add ()
+     in
+     let output_buffer = GText.buffer ~text:"loading..." () in
+     let _output_win =
+       GText.view ~buffer:output_buffer ~editable:false
+         ~cursor_visible:true ~packing:scroll_output#add ()
+     in
+     F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
+     Toploop.initialize_toplevel_env ();
+     let out_ppf =
+       Format.formatter_of_out_functions
+         Format.
+           {
+             out_string = (fun s _ _ -> output_buffer#insert s);
+             out_flush = (fun () -> ());
+             out_indent =
+               (fun n ->
+                 for _ = 0 to n do
+                   output_buffer#insert "  "
+                 done);
+             out_newline = (fun () -> output_buffer#insert "\n");
+             out_spaces =
+               (fun n -> output_buffer#insert (String.make n ' '));
+           }
+     in
+
+     ignore (GtkMain.BindingSet.make "execute");
+
+     let module GToolbox = struct
+       include GToolbox
+
+       (* mk_keys turns keys from a key_combination into a format which can be used in
+          * a GTK+ RC file. *)
+       let mk_keys (mods, c) =
+         let mods =
+           List.map
+             (function
+               | `A -> "" | `C -> "" | `S -> "")
+             mods
+         in
+         String.concat "" mods
+         ^ String.make 1 (Char.lowercase_ascii c)
+
+       (* Signal creation for shortcuts unfortunately requires us to create an
+        * in-memory gtkrc file which this function do. *)
+       let make_gtkrc_string g_type shortcuts =
+         let sp = Printf.sprintf in
+         let b = Buffer.create 4000 in
+         Buffer.add_string b "binding \"Shortcuts\" {";
+         StdLabels.List.iter shortcuts ~f:(fun t ->
+             ListLabels.iter t.keys ~f:(fun keys ->
+                 let keys = mk_keys keys in
+                 Buffer.add_string b
+                   (sp " bind \"%s\" { \"%s\" () }" keys t.name)));
+         Buffer.add_string b "}";
+         let classname = Gobject.Type.name g_type in
+         Buffer.add_string b
+           (sp "\nclass \"%s\" binding \"Shortcuts\"" classname);
+         Buffer.contents b
+
+       let create_shortcuts ~window:(win : #GWindow.window_skel)
+           ~shortcuts ~callback =
+         let win = win#as_window in
+         let g_type = Gobject.get_type win in
+         F.pr "gtkrc_string: %s@.@."
+           (make_gtkrc_string g_type shortcuts);
+         GtkMain.Rc.parse_string (make_gtkrc_string g_type shortcuts);
+         ListLabels.iter shortcuts ~f:(fun t ->
+             let sgn =
+               {
+                 GtkSignal.name = t.name;
+                 classe = `window;
+                 marshaller = GtkSignal.marshal_unit;
+               }
              in
-             let rootrepo = Store.test_pull () in
-             rootrepo >>= fun (_upstream, t) ->
-             Store.S.tree t >>= fun rootstore ->
-             (try
-                Store.S.Tree.get rootstore [ ".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 ->
-             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);
+             GtkSignal.signal_new t.name g_type
+               [ `ACTION; `RUN_FIRST ];
+             ignore
+               (GtkSignal.connect ~sgn
+                  ~callback:(fun () -> callback t.message)
+                  win))
+     end in
+     GToolbox.create_shortcuts ~window:win
+       ~shortcuts:
+         [
+           {
+             name = "Quit";
+             keys = [ ([ `C ], 'q') ];
+             message = `Quit;
+           };
+           {
+             name = "Execute";
+             keys = [ ([ `C ], 'e') ];
+             message = `Execute;
+           };
+         ]
+       ~callback:(function
+         | `Quit ->
+             F.pr "`Quit@.";
+             F.pf out_ppf "`Quit@.";
+             Lwt.wakeup wakener ()
+         | `Execute ->
+             F.pr "`Execute@.";
+             F.pf out_ppf "`Execute@.";
+             ignore
+               (Toploop.use_input out_ppf
+                  (String (source_buffer#get_text ()))));
 
-         Js._false)
+     (* ignore
+        (Toploop.use_input out_ppf
+           (String "#use \"topfind\";;\n#list;;")); *)
+     output_buffer#set_text "";
+     ignore (Toploop.use_input out_ppf (String text));
+     (* Wait for it to be closed. *)
+     waiter)
diff --git a/ppx_support.ml b/ppx_support.ml
deleted file mode 100644
index 3447ab1..0000000
--- a/ppx_support.ml
+++ /dev/null
@@ -1 +0,0 @@
-let init () = Ast_mapper.register "js_of_ocaml" (fun _ -> Ppx_js.mapper)
diff --git a/store.ml b/store.ml
index b038c93..5193b6c 100644
--- a/store.ml
+++ b/store.ml
@@ -1,345 +1,6 @@
-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 S = Irmin_git_unix.FS.KV (Irmin.Contents.String)
 module Sync = Irmin.Sync.Make (S)
 
 type t = S.tree
@@ -348,6 +9,7 @@ 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
@@ -355,22 +17,8 @@ let test_populate () : t Lwt.t =
   >>= 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" 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 *)
+let init_default upstream_url : Sync.db Lwt.t =
+  S.Repo.v (Irmin_git.Conf.init "../rootstore") >>= fun repo ->
+  S.of_branch repo "lablgtk" >>= fun t ->
+  S.remote upstream_url >>= fun upstream ->
+  Sync.pull_exn t upstream `Set >>= fun _ -> Lwt.return t
diff --git a/test_dynlink.ml b/test_dynlink.ml
deleted file mode 100644
index c371708..0000000
--- a/test_dynlink.ml
+++ /dev/null
@@ -1,3 +0,0 @@
-let _ = print_endline "Dynlink OK"
-
-let f () = print_endline "Test_dynlink.f Ok"