diff --git a/.config/dune b/.config/dune index 6b9652b..7787cfd 100644 --- a/.config/dune +++ b/.config/dune @@ -1,7 +1,9 @@ +(env + (dev (flags (:standard -warn-error -A)))) + (library (name init) (libraries - store js_of_ocaml-compiler js_of_ocaml-tyxml js_of_ocaml-toplevel lwt js_of_ocaml-lwt ;; not used directly @@ -14,6 +16,15 @@ js_of_ocaml-lwt.graphics js_of_ocaml-ppx uucp - httpaf) - (modules init) + httpaf + digestif.ocaml + checkseum.ocaml + irmin.mem + git + irmin-git + cohttp-lwt-jsoo + mimic) + (modules init store) + (preprocess + (pps js_of_ocaml-ppx)) ) diff --git a/.config/init.ml b/.config/init.ml index 3a1205c..6d7f789 100644 --- a/.config/init.ml +++ b/.config/init.ml @@ -112,3 +112,22 @@ let setup_workspace ~container cstore : unit Lwt.t = csl in cstore >>= render ~container + +let _ = + Lwt.async (fun () -> + let container = by_id "toplevel-container" in + let textbox : 'a Js.t = + by_id_coerce "userinput" Dom_html.CoerceTo.textarea + in + let rootstore = Store.test_pull () in + rootstore >>= fun rs -> + let workspace_store = + Store.S.Tree.find_tree rs [ ".config"; "workspace" ] + >>= function + | Some t -> Lwt.return t + | None -> Lwt.return (Store.S.Tree.empty ()) + in + setup_storeview ~storeview:rootstore ~container ~textbox; + Lwt.return + (Lwt.async (fun () -> + setup_workspace ~container workspace_store))) diff --git a/.config/store.ml b/.config/store.ml new file mode 100644 index 0000000..8d4f8e1 --- /dev/null +++ b/.config/store.ml @@ -0,0 +1,382 @@ +open Js_of_ocaml +open Lwt.Infix +module F = Fmt +module Cohttp_backend = Cohttp_lwt_jsoo + +module Git_af = struct + open Lwt.Infix + + type error = | + + let git_af_scheme : [ `HTTP | `HTTPS ] Mimic.value = + Mimic.make ~name:"git-af-scheme" + + let git_af_port : int Mimic.value = Mimic.make ~name:"git-af-port" + + let git_af_hostname : string Mimic.value = + Mimic.make ~name:"git-af-hostname" + + let pp_error : error Fmt.t = fun _ppf -> function _ -> . + + let with_redirects ?(max = 10) ~f uri = + if max < 10 then invalid_arg "with_redirects"; + let tbl = Hashtbl.create 0x10 in + let rec go max uri = + f uri >>= fun (resp, body) -> + let status_code = + Cohttp.(Response.status resp |> Code.code_of_status) + in + if Cohttp.Code.is_redirection status_code then + match + Cohttp.(Response.headers resp |> Header.get_location) + with + | Some uri' when Hashtbl.mem tbl uri' || max = 0 -> + Lwt.return (resp, body) + | Some uri' -> + Hashtbl.add tbl uri' (); + Cohttp_lwt.Body.drain_body body >>= fun () -> + go (pred max) uri' + | None -> Lwt.return (resp, body) + else Lwt.return (resp, body) + in + go max uri + + let get ~ctx:_ ?(headers = []) uri = + Firebug.console##log (Js.string "Git_Cohttp_console.get()\n"); + let headers = Cohttp.Header.of_list headers in + let f uri = Cohttp_backend.Client.get ~headers uri in + with_redirects ~f uri >>= fun (_resp, body) -> + Cohttp_lwt.Body.to_string body >>= fun body -> + Lwt.return_ok ((), body) + + let post ~ctx:_ ?(headers = []) uri body = + let headers = Cohttp.Header.of_list headers in + let body = Cohttp_lwt.Body.of_string body in + let f uri = + Cohttp_backend.Client.post ~headers ~chunked:false ~body uri + in + with_redirects ~f uri >>= fun (_resp, body) -> + Cohttp_lwt.Body.to_string body >>= fun body -> + Lwt.return_ok ((), body) +end + +module Git_console_http = struct + open Lwt.Infix + + let context ctx = + (* HTTP *) + let edn = Mimic.make ~name:"af-http-endpoint" in + let k1 git_af_scheme git_af_hostname git_af_port = + match git_af_scheme with + | `HTTP -> Lwt.return_some (git_af_hostname, git_af_port) + | _ -> Lwt.return_none + in + let ctx = + Mimic.fold edn + Mimic.Fun. + [ + req Git_af.git_af_scheme; + req Git_af.git_af_hostname; + dft Git_af.git_af_port 80; + ] + ~k:k1 ctx + in + + (* HTTPS *) + let edn = Mimic.make ~name:"af-https-endpoint" in + let k1 git_af_scheme git_af_hostname git_af_port = + match git_af_scheme with + | `HTTPS -> Lwt.return_some (git_af_hostname, git_af_port) + | _ -> Lwt.return_none + in + + let ctx = + Mimic.fold edn + Mimic.Fun. + [ + req Git_af.git_af_scheme; + req Git_af.git_af_hostname; + dft Git_af.git_af_port 443; + ] + ~k:k1 ctx + in + + ctx + + module HTTP = struct + type state = + | Handshake + | Get of { + advertised_refs : string; + uri : Uri.t; + headers : (string * string) list; + ctx : Mimic.ctx; + } + | Post of { + mutable output : string; + uri : Uri.t; + headers : (string * string) list; + ctx : Mimic.ctx; + } + | Error + + type flow = { endpoint : Uri.t; mutable state : state } + type error = [ `Msg of string ] + type write_error = [ `Closed | `Msg of string ] + + let pp_error ppf (`Msg err) = Fmt.string ppf err + + let pp_write_error ppf = function + | `Closed -> Fmt.string ppf "Connection closed by peer" + | `Msg err -> Fmt.string ppf err + + let write t cs = + match t.state with + | Handshake | Get _ -> + Lwt.return_error (`Msg "Handshake has not been done") + | Error -> Lwt.return_error (`Msg "Handshake got an error") + | Post ({ output; _ } as v) -> + let output = output ^ Cstruct.to_string cs in + v.output <- output; + Lwt.return_ok () + + let writev t css = + let rec go = function + | [] -> Lwt.return_ok () + | x :: r -> ( + write t x >>= function + | Ok () -> go r + | Error _ as err -> Lwt.return err) + in + go css + + let read t = + match t.state with + | Handshake -> + Lwt.return_error (`Msg "Handshake has not been done") + | Error -> Lwt.return_error (`Msg "Handshake got an error") + | Get { advertised_refs; uri; headers; ctx } -> + t.state <- Post { output = ""; uri; headers; ctx }; + Lwt.return_ok (`Data (Cstruct.of_string advertised_refs)) + | Post { output; uri; headers; ctx } -> ( + Git_af.post ~ctx ~headers uri output >>= function + | Ok (_resp, contents) -> + Lwt.return_ok (`Data (Cstruct.of_string contents)) + | Error err -> + Lwt.return_error + (`Msg (Fmt.str "%a" Git_af.pp_error err))) + + let close _ = Lwt.return_unit + + type endpoint = Uri.t + + let connect endpoint = + Firebug.console##log + (Js.string "Git_Console_http.HTTP.connect()\n"); + Lwt.return_ok { endpoint; state = Handshake } + end + + let http_endpoint, http_protocol = + Mimic.register ~name:"http" (module HTTP) + + let connect (ctx : Mimic.ctx) = + Firebug.console##log (Js.string "Git_Console_http.connect()\n"); + let module T = (val Mimic.repr http_protocol) in + let edn = Mimic.make ~name:"http-endpoint" in + let k0 uri = Lwt.return_some uri in + let k1 git_transmission git_scheme = + match (git_transmission, git_scheme) with + | `HTTP (uri, _), (`HTTP | `HTTPS) -> Lwt.return_some uri + | _ -> Lwt.return_none + in + let k2 git_scheme git_uri git_http_headers = + match git_scheme with + | `Git | `SSH | `Scheme _ -> Lwt.return_none + | `HTTP | `HTTPS -> + let headers = + ("content-type", "application/x-git-upload-pack-request") + :: git_http_headers + in + let handshake ~uri0 ~uri1 = function + | T.T flow -> ( + Firebug.console##log + (Js.string + (F.str + "Git_Console_http.connect.k2.handshake \ + uri0='%s' uri1='%s'\n" + (Uri.to_string uri0) (Uri.to_string uri1))); + let ctx = context Mimic.empty in + Git_af.get ~ctx ~headers uri0 >>= function + | Ok (_resp, advertised_refs) -> + flow.state <- + HTTP.Get + { advertised_refs; uri = uri1; headers; ctx }; + Lwt.return_unit + | Error _ -> + flow.state <- Error; + Lwt.return_unit) + | _ -> Lwt.return_unit + in + let git_transmission = `HTTP (git_uri, handshake) in + Lwt.return_some git_transmission + in + let ctx = + Mimic.fold http_endpoint Mimic.Fun.[ req edn ] ~k:k0 ctx + in + let ctx = + Mimic.fold edn + Mimic.Fun. + [ req Smart_git.git_transmission; req Smart_git.git_scheme ] + ~k:k1 ctx + in + let ctx = + Mimic.fold Smart_git.git_transmission + Mimic.Fun. + [ + req Smart_git.git_scheme; + req Smart_git.git_uri; + dft Smart_git.git_http_headers List.[]; + ] + ~k:k2 ctx + in + Lwt.return ctx +end + +module Config = struct + open Irmin.Backend.Conf + + let spec = Spec.v "console_js_git" + + module Key = struct + let reference : Git.Reference.t Irmin.Type.t = + let of_string str = + Git.Reference.of_string str |> Result.get_ok + in + let to_string r = Git.Reference.to_string r in + Irmin.Type.(map string) of_string to_string + + let head = + key ~spec ~doc:"The main branch of the Git repository." "head" + Irmin.Type.(option reference) + None + + let bare = + key ~spec ~doc:"Do not expand the filesystem on the disk." + "bare" Irmin.Type.bool false + + let level = + key ~spec ~doc:"The Zlib compression level." "level" + Irmin.Type.(option int) + None + + let buffers = + key ~spec ~doc:"The number of 4K pre-allocated buffers." + "buffers" + Irmin.Type.(option int) + None + end + + let init ?head ?level ?buffers _root = + let module C = Irmin.Backend.Conf in + let config = C.empty spec in + + let config = C.add config Key.head head in + let config = C.add config Key.level level in + let config = C.add config Key.buffers buffers in + C.verify config +end + +module S = struct + module Schema = + Irmin_git.Schema.Make (Git.Mem.Store) (Irmin.Contents.String) + (Irmin_git.Branch.Make (Irmin.Branch.String)) + + module Sync' = struct + module GitMemSync = Git.Mem.Sync (Git.Mem.Store) + include GitMemSync + (* This is where the fetch and push are broken *) + end + + module SMaker = Irmin_git.Maker (Git.Mem.Store) (Sync') + module SMade = SMaker.Make (Schema) + include SMade + + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + + let remote ?(ctx = Mimic.empty) ?headers uri = + E + (Firebug.console##log + (Js.string (F.str "Nav.S.remote(uri=%s)\n" uri)); + let ( ! ) f a b = f b a in + match Smart_git.Endpoint.of_string uri with + | Ok edn -> + let edn = + Option.fold ~none:edn + ~some:(!Smart_git.Endpoint.with_headers_if_http edn) + headers + in + Firebug.console##log + (Js.string "Nav.S.remote() = (ctx, edn) \n"); + (ctx, edn) + | Error (`Msg err) -> Fmt.invalid_arg "remote: %s" err) + + module Backend = struct + include Backend + module R = Remote + + module Remote = struct + include R + + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + + let ctx e = fst e + let edn e = snd e + + let fetch t ?depth endpoint branch = + Firebug.console##log + (Js.string "S.Backend.Remote.wrapped_fetch()\n"); + R.fetch t ?depth endpoint branch + end + end +end + +module Sync = Irmin.Sync.Make (S) + +type t = S.tree +type tree = t +type step = S.step +type path = step list + +let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree + +let test_populate () : t Lwt.t = + let add p s t = S.Tree.add t p s in + add [ "hello" ] "world" (S.Tree.empty ()) + >>= add [ "hello"; "daddy" ] "ily" + >>= add [ "beep"; "beep" ] "motherfucker" + +let test_pull () : t Lwt.t = + (* test_populate ()*) + Firebug.console##log (Js.string "Nav.test_pull()\n"); + S.Repo.v (Config.init "") >>= fun repo -> + Firebug.console##log (Js.string "Nav.test_pull(2)\n"); + S.of_branch repo "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", + "Basic \ + Y3FjOmQ5YzJiNDkxZTcwZTMxYTc2MGNlNzBiYzQzMTAzNmM5MTMyNWY2ODM=" + ); + ] + "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"); + S.tree t +(* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *)