Skip to content

Instantly share code, notes, and snippets.

@hannesm hannesm/config.ml Secret
Created Apr 3, 2019

Embed
What would you like to do?
push and pull
open Mirage
let remote_k =
let doc = Key.Arg.info ~doc:"Remote git repository." ["r"; "remote"] in
Key.(create "remote" Arg.(opt string "https://github.com/roburio/udns.git" doc))
let dns_handler =
let packages = [
package "logs" ;
package "irmin-mirage";
] in
foreign
~deps:[abstract nocrypto]
~keys:[Key.abstract remote_k]
~packages
"Unikernel.Main"
(random @-> pclock @-> mclock @-> time @-> stackv4 @-> resolver @-> conduit @-> job)
let () =
let net = generic_stackv4 default_network in
register "push-pull"
[dns_handler $ default_random $ default_posix_clock $ default_monotonic_clock $
default_time $ net $ resolver_dns net $ conduit_direct ~tls:true net]
open Lwt.Infix
open Mirage_types_lwt
module Main (R : RANDOM) (P : PCLOCK) (M : MCLOCK) (T : TIME) (S : STACKV4) (RES: Resolver_lwt.S) (CON: Conduit_mirage.S) = struct
module ROStore = Irmin_mirage.Git.KV_RO(Irmin_git.Mem)
let load_data conduit resolver =
Irmin_git.Mem.v (Fpath.v ".") >>= function
| Error _ -> assert false
| Ok git ->
ROStore.connect git ~conduit ~resolver (Key_gen.remote ()) >>= fun store ->
ROStore.list store Mirage_kv.Key.empty >>= function
| Error e ->
Logs.err (fun m -> m "error %a while listing store" ROStore.pp_error e) ;
assert false
| Ok files ->
Lwt_list.fold_left_s (fun acc -> function
| name, `Dictionary ->
Logs.err (fun m -> m "got dictionary, expected value for %s" name) ;
Lwt.return acc
| name, `Value ->
ROStore.get store (Mirage_kv.Key.v name) >|= function
| Error e ->
Logs.err (fun m -> m "error %a while reading %s" ROStore.pp_error e name) ;
assert false
| Ok data -> (name, data) :: acc)
[] files
let load_git conduit resolver =
load_data conduit resolver >|= fun bindings ->
Logs.info (fun m -> m "found %d bindings: %a" (List.length bindings)
Fmt.(list ~sep:(unit ",@ ") (pair ~sep:(unit ": ") string int))
(List.map (fun (k, v) -> k, String.length v) bindings)) ;
bindings
module Store = Irmin_mirage.Git.KV_RW(Irmin_git.Mem)(P)
let store_data resolver conduit name data =
Irmin_git.Mem.v (Fpath.v ".") >>= function
| Error _ -> assert false
| Ok git ->
Store.connect git ~conduit ~resolver ~author:"push pull"
~msg:(fun _ -> "a change") () (Key_gen.remote ()) >>= fun store ->
Store.set store (Mirage_kv.Key.v name) data >|= function
| Ok () -> Logs.app (fun m -> m "pushed data")
| Error e ->
(* TODO bail out!? try again? (https://github.com/mirage/ocaml-git/issues/342) *)
Logs.err (fun m -> m "error while pushing data %a" Store.pp_write_error e)
let start _rng _pclock _mclock _time s resolver conduit _ =
S.listen_tcpv4 s ~port:1234 (fun flow ->
let src, src_port = S.TCPV4.dst flow in
Logs.info (fun f -> f "new READ tcp connection from IP %s on port %d"
(Ipaddr.V4.to_string src) src_port);
load_git conduit resolver >>= fun bindings ->
S.TCPV4.write flow (Cstruct.of_string (String.concat "," (List.map (fun (k, v) -> k ^ ": " ^ v) bindings))) >|= function
| Ok _ -> Logs.info (fun m -> m "dumped")
| Error e -> Logs.err (fun m -> m "error %a while dumping" S.TCPV4.pp_write_error e)) ;
S.listen_tcpv4 s ~port:1235 (fun flow ->
let src, src_port = S.TCPV4.dst flow in
Logs.info (fun f -> f "new tcp connection from IP %s on port %d"
(Ipaddr.V4.to_string src) src_port);
S.TCPV4.read flow >>= function
| Ok `Eof -> Logs.err (fun m -> m "received eof") ; Lwt.return_unit
| Error e -> Logs.err (fun m -> m "error %a while reading" S.TCPV4.pp_error e) ; Lwt.return_unit
| Ok (`Data data) ->
let str = Cstruct.to_string data in
match String.split_on_char ':' str with
| k :: v -> store_data resolver conduit k (String.concat ":" v)
| _ -> Logs.err (fun m -> m "couldn't parse %s into key:value" str) ; Lwt.return_unit) ;
S.listen s
end
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.