diff --git a/main_mirage/.gitignore b/main_mirage/.gitignore new file mode 100644 index 0000000..886602a --- /dev/null +++ b/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 diff --git a/main_mirage/config.ml b/main_mirage/config.ml new file mode 100644 index 0000000..87f33ad --- /dev/null +++ b/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 ] diff --git a/main_mirage/unikernel.ml b/main_mirage/unikernel.ml new file mode 100644 index 0000000..2c480a9 --- /dev/null +++ b/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