Skip to content

update to recent paf and irmin #9

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
hannesm wants to merge 1 commit into from
Closed

update to recent paf and irmin #9

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
52 changes: 18 additions & 34 deletions config.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,8 +2,9 @@

open Mirage

(* boilerplate from https://github.com/mirage/ocaml-git.git unikernel/config.ml
(commit #3bfcf215f959b71580e5c0b655700bb9484aee8c) *)
(* boilerplate from https://github.com/mirage/ocaml-git.git
unikernel/empty-commit/config.ml
(commit #ecdfc6dc13834f5f1a8e378718512eda6e67c982) *)
type mimic = Mimic

let mimic = typ Mimic
Expand Down Expand Up @@ -90,13 +91,13 @@ let mimic_dns_conf =
let packages = [ package "git-mirage" ~sublibs:[ "dns" ] ] in
impl @@ object
inherit base_configurable
method ty = random @-> mclock @-> time @-> stackv4v6 @-> mimic @-> mimic
method ty = random @-> mclock @-> pclock @-> time @-> stackv4v6 @-> mimic @-> mimic
method module_name = "Git_mirage_dns.Make"
method! packages = Key.pure packages
method name = "dns_ctx"
method! connect _ modname =
function
| [ _; _; _; stack; tcp_ctx ] ->
| [ _; _; _; _; stack; tcp_ctx ] ->
Fmt.str
{ocaml|let dns_ctx00 = Mimic.merge %s %s.ctx in
let dns_ctx01 = %s.with_dns %s dns_ctx00 in
Expand All @@ -106,47 +107,31 @@ let mimic_dns_conf =
| _ -> assert false
end

let mimic_dns_impl random mclock time stackv4v6 mimic_tcp =
mimic_dns_conf $ random $ mclock $ time $ stackv4v6 $ mimic_tcp

type paf = Paf
let paf = typ Paf

let paf_conf () =
let packages = [ package "paf" ~sublibs:[ "mirage" ] ] in
impl @@ object
inherit base_configurable
method ty = time @-> stackv4v6 @-> paf
method module_name = "Paf_mirage.Make"
method! packages = Key.pure packages
method name = "paf"
end

let paf_impl time stackv4v6 = paf_conf () $ time $ stackv4v6
let mimic_dns_impl random mclock pclock time stackv4v6 mimic_tcp =
mimic_dns_conf $ random $ mclock $ pclock $ time $ stackv4v6 $ mimic_tcp

let mimic_paf_conf () =
let packages = [ package "git-paf" ] in
impl @@ object
inherit base_configurable
method ty = time @-> pclock @-> stackv4v6 @-> paf @-> mimic @-> mimic
method ty = time @-> pclock @-> stackv4v6 @-> mimic @-> mimic
method module_name = "Git_paf.Make"
method! packages = Key.pure packages
method name = "paf_ctx"
method! connect _ modname = function
| [ _; _; _; _; tcp_ctx; ] ->
| [ _; _; _; tcp_ctx; ] ->
Fmt.str
{ocaml|let paf_ctx00 = Mimic.merge %s %s.ctx in
Lwt.return paf_ctx00|ocaml}
tcp_ctx modname
| _ -> assert false
end

let mimic_paf_impl time pclock stackv4v6 paf mimic_tcp =
let mimic_paf_impl time pclock stackv4v6 mimic_tcp =
mimic_paf_conf ()
$ time
$ pclock
$ stackv4v6
$ paf
$ mimic_tcp
(* --- end of copied code --- *)

Expand All @@ -166,30 +151,29 @@ let authenticator =
let doc = Key.Arg.info ~doc:"Authenticator." ["authenticator"] in
Key.(create "authenticator" Arg.(opt (some string) None doc))

let mimic_impl ~kind ~seed ~authenticator stackv4v6 random mclock pclock time paf =
let mimic_impl ~kind ~seed ~authenticator stackv4v6 random mclock pclock time =
let mtcp = mimic_tcp_impl stackv4v6 in
let mdns = mimic_dns_impl random mclock time stackv4v6 mtcp in
let mdns = mimic_dns_impl random mclock pclock time stackv4v6 mtcp in
let mssh = mimic_ssh_impl ~kind ~seed ~auth:authenticator stackv4v6 mtcp mclock in
let mpaf = mimic_paf_impl time pclock stackv4v6 paf mtcp in
let mpaf = mimic_paf_impl time pclock stackv4v6 mtcp in
merge mpaf (merge mssh mdns)

let net = generic_stackv4v6 default_network

let mimic_impl =
mimic_impl ~kind:`Rsa ~seed ~authenticator net
default_random default_monotonic_clock default_posix_clock default_time
(paf_impl default_time net)

let dns_handler =
let packages = [
package "logs" ;
package ~min:"5.0.0" ~sublibs:["mirage"; "zone"] "dns-server";
package "dns-tsig";
package ~min:"2.6.0" "irmin-mirage";
package ~min:"2.6.0" "irmin-mirage-git";
package ~min:"3.4.0" "git-mirage";
package "git-paf";
package ~sublibs:["cohttp"] "paf";
package ~min:"2.8.0" "irmin-mirage";
package ~min:"2.8.0" "irmin-mirage-git";
package ~min:"3.6.0" "git-mirage";
package ~min:"3.5.0" "git-paf";
package ~min:"0.0.6" ~sublibs:["mirage"] "paf";
] in
foreign
~keys:[Key.abstract remote_k ; Key.abstract axfr]
Expand Down
12 changes: 6 additions & 6 deletions unikernel.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -41,7 +41,7 @@ module Main (R : Mirage_random.S) (P : Mirage_clock.PCLOCK) (M : Mirage_clock.MC
| Error (ctx, e) -> Error (`Msg ("while loading zones from git: " ^ ctx ^ " " ^ e))
| Ok bindings ->
Logs.info (fun m -> m "found %d bindings: %a" (List.length bindings)
Fmt.(list ~sep:(unit ",@ ") (pair ~sep:(unit ": ") Domain_name.pp int))
Fmt.(list ~sep:(any ",@ ") (pair ~sep:(any ": ") Domain_name.pp int))
(List.map (fun (k, v) -> k, String.length v) bindings)) ;
let open Rresult.R.Infix in
(* split into keys and zones *)
Expand All @@ -62,7 +62,7 @@ module Main (R : Mirage_random.S) (P : Mirage_clock.PCLOCK) (M : Mirage_clock.MC
let zone_rrs = Domain_name.Map.filter (fun name _ -> in_zone name) rrs in
let trie' = Dns_trie.insert_map zone_rrs trie in
Rresult.R.reword_error
(fun _ -> `Msg (Fmt.strf "no SOA for %a" Domain_name.pp zone))
(fun _ -> `Msg (Fmt.str "no SOA for %a" Domain_name.pp zone))
(Dns_trie.lookup zone Dns.Rr_map.Soa trie') >>= fun _ ->
Rresult.R.reword_error
(fun e -> `Msg (Fmt.to_to_string Dns_trie.pp_zone_check e))
Expand Down Expand Up @@ -173,8 +173,8 @@ module Main (R : Mirage_random.S) (P : Mirage_clock.PCLOCK) (M : Mirage_clock.MC
| Ok data ->
let info () =
let date = Int64.of_float Ptime.Span.(to_float_s (v (P.now_d_ps ())))
and commit = Fmt.strf "%a changed %a" Ipaddr.pp ip Domain_name.pp zone
and author = Fmt.strf "%a via pimary git" Fmt.(option ~none:(unit "no key") Domain_name.pp) key
and commit = Fmt.str "%a changed %a" Ipaddr.pp ip Domain_name.pp zone
and author = Fmt.str "%a via pimary git" Fmt.(option ~none:(any "no key") Domain_name.pp) key
in
Irmin.Info.v ~date ~author commit
in
Expand Down Expand Up @@ -219,10 +219,10 @@ module Main (R : Mirage_random.S) (P : Mirage_clock.PCLOCK) (M : Mirage_clock.MC
and on_notify n t =
match n with
| `Notify soa ->
Logs.err (fun m -> m "ignoring normal notify %a" Fmt.(option ~none:(unit "no soa") Dns.Soa.pp) soa);
Logs.err (fun m -> m "ignoring normal notify %a" Fmt.(option ~none:(any "no soa") Dns.Soa.pp) soa);
Lwt.return None
| `Signed_notify soa ->
Logs.info (fun m -> m "got notified, checking out %a" Fmt.(option ~none:(unit "no soa") Dns.Soa.pp) soa);
Logs.info (fun m -> m "got notified, checking out %a" Fmt.(option ~none:(any "no soa") Dns.Soa.pp) soa);
load_git (Some (Dns_server.Primary.data t)) store upstream >|= function
| Error (`Msg msg) ->
Logs.err (fun m -> m "error %s while loading git while in notify, continuing with old data" msg);
Expand Down