fix init.ml
This commit is contained in:
cqc
382
.config/store.ml
Normal file
382
.config/store.ml
Normal file
@ -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 *)
|
||||
Reference in New Issue
Block a user