Miragify

main_mirage/.gitignore

@@ -0,0 +1,9 @@
+_build
+.mirage.config
+Makefile
+key_gen.ml
+main.ml
+mirage-unikernel-rss_to_mail-unix.opam
+myocamlbuild.ml
+main.native
+rss_to_mail

main_mirage/config.ml

@@ -0,0 +1,14 @@
+open Mirage
+
+let main =
+  foreign
+    "Unikernel.Main"
+    ~packages:[ package "cohttp-mirage" ]
+    (time @-> resolver @-> conduit @-> kv_rw @-> job)
+
+let () =
+  let stack = generic_stackv4 default_network in
+  let res_dns = resolver_dns stack in
+  let conduit = conduit_direct stack in
+  let kv_rw = direct_kv_rw "persistent_storage" in
+  register "rss_to_mail" [ main $ default_time $ res_dns $ conduit $ kv_rw ]

main_mirage/unikernel.ml

@@ -0,0 +1,58 @@
+open Lwt.Infix
+open Mirage_types_lwt
+
+let pooled n f =
+  let pool = Lwt_pool.create n (fun _ -> Lwt.return_unit) in
+  fun x -> Lwt_pool.use pool (fun () -> f x)
+
+module Fetch = struct
+  let rec get ~ctx ?(max_redirect=5) url =
+    Cohttp_mirage.Client.get ~ctx url >>= fun (resp, body) ->
+    match resp.status with
+    | (`Moved_permanently
+      | `Found
+      | `Temporary_redirect)
+      when max_redirect > 0 ->
+      let max_redirect = max_redirect - 1 in
+      let headers = Cohttp.Response.headers resp in
+      begin match Cohttp.Header.get headers "location" with
+        | Some url		-> get ~ctx ~max_redirect (Uri.of_string url)
+        | None			-> Lwt.return (resp, body)
+      end
+    | _ -> Lwt.return (resp, body)
+
+  type error = [ `System of string | `Http of int | `Unknown ]
+
+  let fetch ~ctx url =
+    Logs.info (fun fmt -> fmt "Fetching %a" Uri.pp url);
+    let get () =
+      get ~ctx url >>= function
+      | { Cohttp.Response.status = `OK; _ }, body	->
+        Cohttp_lwt.Body.to_string body >>= fun body ->
+        Lwt.return (Ok body)
+      | { Cohttp.Response.status; _ }, _ ->
+        let code = Cohttp.Code.code_of_status status in
+        Lwt.return (Error (`Http code))
+    in
+    Lwt.catch get (function
+        | Failure msg ->
+          Lwt.return (Error (`System msg))
+        | Unix.Unix_error (_, msg, _)	->
+          Lwt.return (Error (`System msg))
+        | _ ->
+          Lwt.return (Error (`Unknown))
+      )
+
+  (** at most 5 fetch at once *)
+  let fetch ~ctx = pooled 5 (fetch ~ctx)
+end
+
+module Main
+    (Time : TIME)
+    (Resolver: Resolver_lwt.S)
+    (Conduit: Conduit_mirage.S)
+    (Kv_rw: Mirage_kv_lwt.RW)
+= struct
+  let start _time _res_dns _conduit _kv_rw =
+    Lwt.return_unit
+end