From 10c499110baa61feec556fe168f555f8b4b90cf7 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 7 May 2019 14:35:20 +0200 Subject: [PATCH 1/4] Add unikernel skeleton --- main_mirage/.gitignore | 7 +++++++ main_mirage/config.ml | 7 +++++++ main_mirage/unikernel.ml | 3 +++ 3 files changed, 17 insertions(+) create mode 100644 main_mirage/.gitignore create mode 100644 main_mirage/config.ml create mode 100644 main_mirage/unikernel.ml diff --git a/main_mirage/.gitignore b/main_mirage/.gitignore new file mode 100644 index 0000000..827cf9f --- /dev/null +++ b/main_mirage/.gitignore @@ -0,0 +1,7 @@ +_build +.mirage.config +Makefile +key_gen.ml +main.ml +mirage-unikernel-rss_to_mail-unix.opam +myocamlbuild.ml diff --git a/main_mirage/config.ml b/main_mirage/config.ml new file mode 100644 index 0000000..66b9726 --- /dev/null +++ b/main_mirage/config.ml @@ -0,0 +1,7 @@ +open Mirage + +let main = + foreign "Unikernel.Main" job + +let () = + register "rss_to_mail" [main] diff --git a/main_mirage/unikernel.ml b/main_mirage/unikernel.ml new file mode 100644 index 0000000..8454ffb --- /dev/null +++ b/main_mirage/unikernel.ml @@ -0,0 +1,3 @@ +module Main = struct + let start = Lwt.return_unit +end From 64c5147d2f7cc92f2bd4993b92147d1a95b0de65 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 7 May 2019 16:11:19 +0200 Subject: [PATCH 2/4] Declare a few unikernel dependencies --- main_mirage/.gitignore | 2 ++ main_mirage/config.ml | 11 +++++++++-- main_mirage/unikernel.ml | 12 ++++++++++-- 3 files changed, 21 insertions(+), 4 deletions(-) diff --git a/main_mirage/.gitignore b/main_mirage/.gitignore index 827cf9f..886602a 100644 --- a/main_mirage/.gitignore +++ b/main_mirage/.gitignore @@ -5,3 +5,5 @@ 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 index 66b9726..87f33ad 100644 --- a/main_mirage/config.ml +++ b/main_mirage/config.ml @@ -1,7 +1,14 @@ open Mirage let main = - foreign "Unikernel.Main" job + foreign + "Unikernel.Main" + ~packages:[ package "cohttp-mirage" ] + (time @-> resolver @-> conduit @-> kv_rw @-> job) let () = - register "rss_to_mail" [main] + 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 index 8454ffb..d899b7d 100644 --- a/main_mirage/unikernel.ml +++ b/main_mirage/unikernel.ml @@ -1,3 +1,11 @@ -module Main = struct - let start = Lwt.return_unit +open Mirage_types_lwt + +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 From eae7465eb60eb8b66b7f2c7d077ad593079bf22e Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 7 May 2019 17:14:07 +0200 Subject: [PATCH 3/4] TMP: Fetch a fixed url in unikernel --- main_mirage/unikernel.ml | 43 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/main_mirage/unikernel.ml b/main_mirage/unikernel.ml index d899b7d..0a65eaf 100644 --- a/main_mirage/unikernel.ml +++ b/main_mirage/unikernel.ml @@ -1,5 +1,48 @@ +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); + match%lwt get ~ctx url with + | exception Failure msg -> + Lwt.return (Error (`System msg)) + | exception Unix.Unix_error (_, msg, _) -> + Lwt.return (Error (`System msg)) + | exception _ -> + Lwt.return (Error (`Unknown)) + | { status = `OK; _ }, body -> + let%lwt body = Cohttp_lwt.Body.to_string body in + Lwt.return (Ok body) + | { status; _ }, _ -> + let code = Cohttp.Code.code_of_status status in + Lwt.return (Error (`Http code)) + + (** at most 5 fetch at once *) + let fetch ~ctx = pooled 5 (fetch ~ctx) +end + module Main (Time : TIME) (Resolver: Resolver_lwt.S) From 3375e967cca748422a33f2d4784ff0a0b5ba0593 Mon Sep 17 00:00:00 2001 From: juloo Date: Thu, 9 May 2019 21:45:40 +0200 Subject: [PATCH 4/4] Build without lwt_ppx --- main_mirage/unikernel.ml | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/main_mirage/unikernel.ml b/main_mirage/unikernel.ml index 0a65eaf..2c480a9 100644 --- a/main_mirage/unikernel.ml +++ b/main_mirage/unikernel.ml @@ -25,19 +25,23 @@ module Fetch = struct let fetch ~ctx url = Logs.info (fun fmt -> fmt "Fetching %a" Uri.pp url); - match%lwt get ~ctx url with - | exception Failure msg -> - Lwt.return (Error (`System msg)) - | exception Unix.Unix_error (_, msg, _) -> - Lwt.return (Error (`System msg)) - | exception _ -> - Lwt.return (Error (`Unknown)) - | { status = `OK; _ }, body -> - let%lwt body = Cohttp_lwt.Body.to_string body in - Lwt.return (Ok body) - | { status; _ }, _ -> - let code = Cohttp.Code.code_of_status status in - Lwt.return (Error (`Http code)) + 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)