initial commit

README.md

@@ -0,0 +1,7 @@
+# opam-mirror unikernel
+
+This unikernel periodically (at startup, on request, every hour) updates the
+provided opam-repositor(ies) and downloads all referenced archives. It acts as
+an opam-repository including archive mirror. Only archives with appropriate
+checksums are stored. On startup, all data present on the block device is
+validated.

mirage/README.md

@@ -0,0 +1,4 @@
+Please note that the following pins are needed for getting this to work:
+- paf.0.0.9 git+https://github.com/hannesm/paf-le-chien.git#h2-0.9.0
+- paf-cohttp.0.0.9 git+https://github.com/hannesm/paf-le-chien.git#h2-0.9.0
+- paf-le.0.0.9 git+https://github.com/hannesm/paf-le-chien.git#h2-0.9.0

mirage/config.ml

@@ -0,0 +1,25 @@
+open Mirage
+
+type paf = Paf
+let paf = typ Paf
+
+let paf_conf () =
+  let packages = [ package "paf" ~sublibs:[ "mirage" ] ] in
+  impl ~packages "Paf_mirage.Make" (time @-> tcpv4v6 @-> paf)
+
+let uri =
+  let doc = Key.Arg.info ~doc:"URI" [ "u"; "uri" ] in
+  Key.(create "uri" Arg.(required string doc))
+
+let mirror =
+  foreign "Unikernel.Make"
+    ~keys:[ Key.v uri ]
+    ~packages:[ package "paf" ~min:"0.0.9" ; package "paf-cohttp" ~min:"0.0.7" ]
+    (console @-> time @-> pclock @-> stackv4v6 @-> dns_client @-> paf @-> job)
+
+let paf time stackv4v6 = paf_conf () $ time $ tcpv4v6_of_stackv4v6 stackv4v6
+
+let stackv4v6 = generic_stackv4v6 default_network
+
+let () = register "mirror"
+    [ mirror $ default_console $ default_time $ default_posix_clock $ stackv4v6 $ generic_dns_client stackv4v6 $ paf default_time stackv4v6 ]

mirage/unikernel.ml

@@ -0,0 +1,79 @@
+module type DNS = sig
+  type t
+
+  val gethostbyname : t -> [ `host ] Domain_name.t ->
+    (Ipaddr.V4.t, [> `Msg of string ]) result Lwt.t
+end
+
+open Lwt.Infix
+
+module Make
+  (Console : Mirage_console.S)
+  (Time : Mirage_time.S)
+  (Pclock : Mirage_clock.PCLOCK)
+  (Stack : Tcpip.Stack.V4V6)
+  (Dns : DNS) (* XXX(dinosaure): ask @hannesm to provide a signature. *)
+  (Paf : Paf_mirage.S with type stack = Stack.TCP.t and type ipaddr = Ipaddr.t) = struct
+  module Client = Paf_cohttp
+  module Nss = Ca_certs_nss.Make(Pclock)
+
+  let authenticator = Result.get_ok (Nss.authenticator ())
+  let default_tls_cfg = Tls.Config.client ~authenticator ()
+
+  let stack = Mimic.make ~name:"stack"
+  let tls = Mimic.make ~name:"tls"
+
+  let with_stack v ctx = Mimic.add stack (Stack.tcp v) ctx
+
+  let with_tcp ctx =
+    let k scheme stack ipaddr port =
+      match scheme with
+      | `HTTP -> Lwt.return_some (stack, ipaddr, port)
+      | _ -> Lwt.return_none
+    in
+    Mimic.(fold Paf.tcp_edn Fun.[ req Client.scheme
+                                ; req stack
+                                ; req Client.ipaddr
+                                ; dft Client.port 80 ] ~k ctx)
+
+  let with_tls ctx =
+    let k scheme domain_name cfg stack ipaddr port =
+      match scheme with
+      | `HTTPS -> Lwt.return_some (domain_name, cfg, stack, ipaddr, port)
+      | _ -> Lwt.return_none
+    in
+    Mimic.(fold Paf.tls_edn Fun.[ req Client.scheme
+                                ; opt Client.domain_name
+                                ; dft tls default_tls_cfg
+                                ; req stack
+                                ; req Client.ipaddr
+                                ; dft Client.port 443 ] ~k ctx)
+
+  let dns = Mimic.make ~name:"dns"
+
+  let with_dns v ctx = Mimic.add dns v ctx
+  let with_sleep ctx = Mimic.add Paf_cohttp.sleep Time.sleep_ns ctx
+
+  let with_resolv ctx =
+    let k dns domain_name =
+      Dns.gethostbyname dns domain_name >>= function
+      | Ok ipv4 -> Lwt.return_some (Ipaddr.V4 ipv4)
+      | _ -> Lwt.return_none in
+    Mimic.(fold Client.ipaddr Fun.[ req dns; req Client.domain_name ] ~k ctx)
+
+  let log console fmt = Fmt.kstr (Console.log console) fmt
+
+  let start console _time _pclock stack dns _paf_cohttp =
+    let uri = Uri.of_string (Key_gen.uri ()) in
+    let ctx =
+      Mimic.empty
+      |> with_sleep
+      |> with_tcp         (* stack -> ipaddr -> port => (stack * ipaddr * port) *)
+      |> with_tls         (* domain_name -> tls -> stack -> ipaddr -> port => (domain_name * tls * stack * ipaddr * port) *)
+      |> with_resolv      (* domain_name => ipaddr *)
+      |> with_stack stack (* stack *)
+      |> with_dns dns     (* dns *) in
+    Client.get ~ctx uri >>= fun (_resp, body) ->
+    Cohttp_lwt.Body.to_string body >>= fun str ->
+    log console "%S\n%!" str
+end