unikernel/duniverse/mirage/lib/functoria/device.ml

@@ -0,0 +1,202 @@
+(*
+ * Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2015-2020 Gabriel Radanne <drupyog@zoho.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+open Action.Syntax
+open Astring
+
+type package = Package.t
+type info = Info.t
+type 'a value = 'a Key.value
+type 'a code = { pos : (string * int * int * int) option; code : string }
+
+let code_opt ?pos fmt = Fmt.kstr (fun code -> { pos; code }) fmt
+let code ~pos fmt = Fmt.kstr (fun code -> { pos = Some pos; code }) fmt
+
+type ('a, 'impl) t = {
+  id : 'a Typeid.t;
+  module_name : string;
+  module_type : 'a Type.t;
+  keys : Key.t list;
+  runtime_args : Runtime_arg.t list;
+  packages : package list value;
+  local_libs : string list;
+  install : info -> Install.t value;
+  connect : info -> string -> string list -> 'a code;
+  dune : info -> Dune.stanza list;
+  configure : info -> unit Action.t;
+  files : (info -> Fpath.t list) option;
+  extra_deps : 'impl list;
+}
+
+let pp : type a b. b Fmt.t -> (a, b) t Fmt.t =
+ fun pp_impl ppf t ->
+  let open Fmt.Dump in
+  let fields =
+    [
+      field "id" (fun t -> t.id) Typeid.pp;
+      field "module_name" (fun t -> t.module_name) string;
+      field "module_type" (fun t -> t.module_type) Type.pp;
+      field "keys" (fun t -> t.keys) (list Key.pp);
+      field "install" (fun _ -> "<dyn>") Fmt.string;
+      field "packages" (fun _ -> "<dyn>") Fmt.string;
+      field "extra_deps" (fun t -> t.extra_deps) (list pp_impl);
+    ]
+  in
+  record fields ppf t
+
+let equal x y = Typeid.equal x.id y.id
+let witness x y = Typeid.witness x.id y.id
+let hash x = Typeid.id x.id
+let default_connect _ _ l = code_opt "return (%s)" (String.concat ~sep:", " l)
+let niet _ = Action.ok ()
+let nil _ = []
+
+let merge empty union a b =
+  match (a, b) with
+  | None, None -> Key.pure empty
+  | Some a, None -> Key.pure a
+  | None, Some b -> b
+  | Some a, Some b -> Key.(pure union $ pure a $ b)
+
+let merge_packages = merge [] List.append
+let merge_install = merge Install.empty Install.union
+
+let v ?packages ?packages_v ?(local_libs = []) ?install ?install_v ?(keys = [])
+    ?(runtime_args = []) ?(extra_deps = []) ?(connect = default_connect)
+    ?(dune = nil) ?(configure = niet) ?files module_name module_type =
+  let id = Typeid.gen () in
+  let packages = merge_packages packages packages_v in
+  let install i =
+    let aux = function None -> None | Some f -> Some (f i) in
+    merge_install (aux install) (aux install_v)
+  in
+  {
+    module_type;
+    id;
+    module_name;
+    keys;
+    runtime_args;
+    connect;
+    packages;
+    local_libs;
+    install;
+    dune;
+    configure;
+    files;
+    extra_deps;
+  }
+
+let id t = Typeid.id t.id
+let module_name t = t.module_name
+let module_type t = t.module_type
+let packages t = t.packages
+let local_libs t = t.local_libs
+let install t = t.install
+let connect t = t.connect
+let configure t = t.configure
+
+let files t i =
+  let gen = Action.generated_files (t.configure i) in
+  match t.files with
+  | None -> gen
+  | Some files -> Fpath.Set.(union gen (of_list (files i)))
+
+let dune t = t.dune
+let keys t = t.keys
+let runtime_args t = t.runtime_args
+let extra_deps t = t.extra_deps
+
+let start ?pos impl_name args =
+  code_opt ?pos "@[(%s.start@ %a@ : unit io)@]" impl_name
+    Fmt.(list ~sep:sp string)
+    args
+
+let uniq t = Fpath.Set.(elements (of_list t))
+let exec_hook i = function None -> Action.ok () | Some h -> h i
+
+let extend ?packages ?packages_v ?dune ?pre_configure ?post_configure ?files t =
+  let files =
+    match (files, t.files) with
+    | None, None -> None
+    | Some f, None | None, Some f -> Some f
+    | Some x, Some y -> Some (fun i -> uniq (x i @ y i))
+  in
+  let packages =
+    Key.(pure List.append $ merge_packages packages packages_v $ t.packages)
+  in
+  let exec pre f post i =
+    let* () = exec_hook i pre in
+    let* () = f i in
+    exec_hook i post
+  in
+  let configure = exec pre_configure t.configure post_configure in
+  let dune =
+    Option.map (fun dune i -> t.dune i @ dune i) dune
+    |> Option.value ~default:t.dune
+  in
+  { t with packages; files; configure; dune }
+
+let nice_name d =
+  module_name d
+  |> String.cuts ~sep:"."
+  |> String.concat ~sep:"_"
+  |> String.Ascii.lowercase
+  |> Misc.Name.ocamlify
+
+type ('a, 'i) device = ('a, 'i) t
+
+module Graph = struct
+  type t =
+    | D : { dev : ('a, _) device; args : t list; deps : t list; id : int } -> t
+
+  type dtree = t
+
+  module IdTbl = Hashtbl.Make (struct
+    type t = dtree
+
+    let hash (D t) = t.id
+    let equal (D t1) (D t2) = Int.equal t1.id t2.id
+  end)
+
+  (* We iter in *reversed* topological order. *)
+  let fold f t z =
+    let tbl = IdTbl.create 50 in
+    let state = ref z in
+    let rec aux v =
+      if IdTbl.mem tbl v then ()
+      else
+        let (D { args; deps; _ }) = v in
+        IdTbl.add tbl v ();
+        List.iter aux deps;
+        List.iter aux args;
+        state := f v !state
+    in
+    aux t;
+    !state
+
+  let impl_name (D { dev; args = _; deps = _; id }) =
+    match Type.is_functor (module_type dev) with
+    | false -> module_name dev
+    | true ->
+        let prefix = Astring.String.Ascii.capitalize (nice_name dev) in
+        Fmt.str "%s__%d" prefix id
+
+  let var_name (D { dev; args = _; deps = _; id }) =
+    let prefix = nice_name dev in
+    Fmt.str "%s__%i" prefix id
+end