config.ml

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]

unikernel.ml

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