swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

44
unikernel/duniverse/mirage/.git-blame-ignore-revs Normal file
View file

@ -0,0 +1,44 @@
# Upgrade to OCamlformat 0.27.0
b265098af1783a23dfcf954820bce04890a694df
# Upgrade to OCamlformat 0.26.0
d2cf205b07b9154bec2a6b490a348457d14fec09
# Only formatting code
c1a1f3c0e275121e9e1f7858eb8469bce9cd586f
# Upgrade to OCamlformat 0.24.1
27fd349a42c2ade2104e95fc054ab5b8a7a45e7a
# Apply ocamlformat
feff3f383c18879418aacdccf70ab4b41a3ee4c8
# Upgrade to OCamlformat 0.23.0
a42241e108273f72ec843ae929b465382cbf358d
# Upgrade to OCamlformat 0.22.4
4f639ec47c0a909a1be7caa73686a4c6fd2202f6
# OCamlformat 0.21.0
c206e4ff6db50bb4853045b82da1eb98561a69e7
c430e1a2113faf607a8263de598fd3744f90c2cf
# OCamlforamt 0.20.1
625fb4db5e8d5ee4feeb4ed9cbb41a985a801881
# use a compact style
c57dff52da107254bc59ccd77a89cdc0c8850629
# OCamlformat 0.19.0
ba8881b6c38dd1272985919be5c50b458b7c9d60
# OCamlformat 0.18.0
ac127995407c52188cff325f94e5bd7f147e91f3
# apply ocamlformat
d6c69bf726ae589eefd4c4b0e65406eb3ef7f9fb
# Upgrade to OCamlformat 0.15.0
c0b1694cee573b6c733c8cb51d96390579b34b58
# Upgrade to OCamlformat 0.14.2
dfb7dd05c6dd85568dd205473799272812cf8b47
# Upgrade to OCamlformat 0.14.1
9ee30a571503a9a78c0acf293c1f23c972493395
# Upgrade to OCamlformat 0.13.0
779f5f651993fe1e1aca1daade7c0525583bfb43
# Upgrade to OCamlformat 0.12.0
1c3a0165d510c75e1702a49999899a2bd3b2f6fa
# dune bu @fmt
c0548358f0872c5067062494f065867bc826f2da
5b1669664948b754a0aec8fdad9984adddc296d3
11194994751069bcebebc451408cb61dfd586791
31ca5ebb1f781a26416f946ba6d1dc80ec972d21
e54ec1347b48768d25d805324db3a71e4ccbec33
d5ba1ce504cdd1bad36bb503b6c5aa52f2e657c5

11
unikernel/duniverse/mirage/.gitignore vendored Normal file
View file

@ -0,0 +1,11 @@
_build
*~
\.\#*
\#*#
*.native
*.byte
*.install
_tests/
.merlin
_opam
.DS_Store

4
unikernel/duniverse/mirage/.ocamlformat Normal file
View file

@ -0,0 +1,4 @@
version = 0.27.0
profile = conventional
break-infix = fit-or-vertical
parse-docstrings = true

1562
unikernel/duniverse/mirage/CHANGES.md Normal file
View file

File diff suppressed because it is too large Load diff

15
unikernel/duniverse/mirage/LICENSE.md Normal file
View file

@ -0,0 +1,15 @@
ISC License
Copyright (X) 2011-2018, the [MirageOS contributors](https://mirage.io/community/#team)
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.

14
unikernel/duniverse/mirage/Makefile Normal file
View file

@ -0,0 +1,14 @@
.PHONY: all clean doc test
all:
dune build
clean:
dune clean
doc:
dune build @doc
test:
dune runtest
INSIDE_FUNCTORIA_TESTS=1 dune exec -- test/functoria/e2e/test.exe

84
unikernel/duniverse/mirage/README.md Normal file
View file

@ -0,0 +1,84 @@
<div align="center">
<a href="https://mirageos.org">
<img src="./logo.svg" alt="MirageOS logo"/>
</a>
<br />
<strong>Build Unikernels in OCaml</strong>
</div>
<div align="center">
<br />
[![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https%3A%2F%2Focaml.ci.dev%2Fbadge%2Fmirage%2Fmirage%2Fmain&logo=ocaml&style=flat-square)](https://ocaml.ci.dev/github/mirage/mirage)
[![docs](https://img.shields.io/badge/doc-online-blue.svg)](https://mirage.github.io/mirage/)
</div>
<hr />
<div align="center">
<em>
MirageOS is a library operating system that constructs secure,
performant and resource-efficient unikernels.
</em>
</div>
## About
MirageOS is a library operating system that constructs unikernels for
secure, high-performance network applications across various cloud
computing and mobile platforms. Developers can write code on a
traditional OS such as Linux or macOS. They can then compile their
code into a fully-standalone, specialised unikernel that runs under
the Xen or KVM hypervisors and lightweight hypervisors like FreeBSD's
BHyve, OpenBSD's VMM. These unikernels can deploy on public clouds,
like Amazon's Elastic Compute Cloud and Google Compute Engine, or
private deployments.
The most up-to-date documentation can be found at the
[homepage](https://mirageos.org). The site is [a self-hosted
unikernel](https://github.com/mirage/mirage-www). Simpler [skeleton
applications](https://github.com/mirage/mirage-skeleton) are also
available online. MirageOS unikernels repositories are also available
[here](https://github.com/roburio/unikernels) or
[there](https://github.com/tarides/unikernels).
### This repository
This repository contains the `mirage` command-line tool to create and
deploy applications with MirageOS. This tool wraps the specialised
configuration and build steps required to build MirageOS on all the
supported targets.
**Local install**
You will need the following:
* a working [OCaml](https://ocaml.org) compiler (4.13.0 or higher).
* the [Opam](https://opam.ocaml.org) source package manager (2.1.0 or higher).
* an x86\_64 or armel Linux host to compile Xen kernels, or FreeBSD, OpenBSD or
MacOS X for the solo5 and userlevel versions.
Then run:
```
$ opam install mirage
$ mirage --version
```
This should display at least version `4.0.0`.
### Using `mirage`
There are multiple stages to using `mirage`:
* write `config.ml` to describe the components of your applications;
* call `mirage configure` to generate the necessary code and metadata;
* optionally call `make depends` to install external dependencies and
download Opam packages in the current [dune](https://dune.build/) workspace.
* call `dune build` to build a unikernel.
You can find documentation, walkthroughs and tutorials over on the
[MirageOS website](https://mirageos.org).
The [install instructions](https://mirageos.org/wiki/install)
are a good place to begin!

57
unikernel/duniverse/mirage/RELEASE.md Normal file
View file

@ -0,0 +1,57 @@
## Tips on making a new release for MirageOS
This document aims to streamline the release process for
MirageOS. It's a living document, evolving with each
release. Contributions to enhance this guide are highly encouraged!
Since opam and CI systems use the latest version number released to
opam-repository, there's some caution needed and there'll be CI runs that are
not successful (since the CI doesn't yet know about your new version number).
## Before the release
- Check that `let min = "xxx" and max = "yyy" in` `lib/mirage.ml`
is a range that contains the new release number.
- Rename `## Unreleased` to `## vXXX (YYY-MM-DD)` in CHANGES.md. Open a
Pull Request (PR) with these changes to begin the release process.
and open a PR
### Version bounds
Mirage generates OCaml code, including device initialization code (usually
named "connect"). To avoid breakage of configured unikernels, package
dependencies are generated as well, with lower and upper bounds.
These bounds need to change:
- if there's a new release of a package (and the "connect" function didn't
change), adjust the upper bound only,
- the code generation in mirage targets a new release of the package, adjust the
lower bound and the upper bound.
### Release `mirage` and `mirage-runtime` to opam-repository
- Tag with `dune-release tag`
- Release to opam-repository with `dune-release`
- Backport packaging fixes in the repo (usually lower-bounds).
Ideally this should be done before submitting to opam-repository but
right now it's not super convenient to do so.
### Update `mirage-skeleton`
- Verify that all changes in the main branch are correctly ported to
the dev branch and vice versa. This step ensures that both branches
reflect the latest, stable changes.
- When complete, force-push dev to become the new main, solidifying
these updates.
- If there are breaking changes, and mirage-skeleton unikernels needed
adjustments, also adjust the first line in config.ml to reflect that:
`(* mirage >= planned_release & < planned_release+1 *)`
- If there are no breaking changes, ensure that mirage-skeleton unikernels
have a good upper bound `(* mirage < planned_release+1 *)`
### Update `mirage-www`
- Confirm that the MirageOS website builds successfully with the newly
released version. To facilitate this, update the `mirageio.opam.template`
pins to test against the new version ahead of the official release.

5
unikernel/duniverse/mirage/bin/dune Normal file
View file

@ -0,0 +1,5 @@
(executable
(name main)
(public_name mirage)
(package mirage)
(libraries mirage))

17
unikernel/duniverse/mirage/bin/main.ml Normal file
View file

@ -0,0 +1,17 @@
(*
* Copyright (c) 2013 Thomas Gazagnaire <thomas@gazagnaire.org>
*
* 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.
*)
let () = Mirage.Tool.run ()

4
unikernel/duniverse/mirage/dune-project Normal file
View file

@ -0,0 +1,4 @@
(lang dune 2.9)
(name mirage)
(version v4.10.3)
(cram enable)

34
unikernel/duniverse/mirage/lib/devices/argv.ml Normal file
View file

@ -0,0 +1,34 @@
open Functoria.DSL
let ty = Functoria.argv
let no_argv =
let connect _ _ _ = code ~pos:__POS__ "return [|\"\"|]" in
impl ~connect "Mirage_runtime" ty
let impl sublib =
let packages =
[
package ~min:"1.0.0" ~max:"2.0.0" ~sublibs:[ ""; sublib ] "mirage-bootvar";
]
in
let connect _ _ _ = code ~pos:__POS__ "return (Mirage_bootvar.argv ())" in
impl ~packages ~connect "Mirage_bootvar" ty
let argv_unix = impl "unix"
let argv_solo5 = impl "solo5"
let argv_xen = impl "xen"
let default_argv =
match_impl
Key.(value target)
[
(`Xen, argv_xen);
(`Qubes, argv_xen);
(`Virtio, argv_solo5);
(`Hvt, argv_solo5);
(`Muen, argv_solo5);
(`Genode, argv_solo5);
(`Spt, argv_solo5);
]
~default:argv_unix

4
unikernel/duniverse/mirage/lib/devices/argv.mli Normal file
View file

@ -0,0 +1,4 @@
open Functoria.DSL
val default_argv : Functoria.argv impl
val no_argv : Functoria.argv impl

17
unikernel/duniverse/mirage/lib/devices/arp.ml Normal file
View file

@ -0,0 +1,17 @@
open Functoria.DSL
type arpv4 = Arpv4
let arpv4 = typ Arpv4
let arp_conf =
let packages =
[ package ~min:"4.0.0" ~max:"5.0.0" ~sublibs:[ "mirage" ] "arp" ]
in
let connect _ modname = function
| [ eth ] -> code ~pos:__POS__ "%s.connect %s" modname eth
| _ -> Misc.connect_err "arp" 1
in
impl ~packages ~connect "Arp.Make" (Ethernet.ethernet @-> arpv4)
let arp (eth : Ethernet.ethernet impl) = arp_conf $ eth

6
unikernel/duniverse/mirage/lib/devices/arp.mli Normal file
View file

@ -0,0 +1,6 @@
open Functoria.DSL
type arpv4
val arpv4 : arpv4 typ
val arp : Ethernet.ethernet impl -> arpv4 impl

345
unikernel/duniverse/mirage/lib/devices/block.ml Normal file
View file

@ -0,0 +1,345 @@
module Dune = Functoria.Dune
module Info = Functoria.Info
module Install = Functoria.Install
open Functoria.DSL
open Functoria.Action
type block = BLOCK
let block = typ BLOCK
type block_t = { filename : string; number : int }
let all_blocks = Hashtbl.create 7
let make_block_t =
(* NB: reserve number 0 for the boot disk *)
let next_number = ref 1 in
fun filename ->
let b =
if Hashtbl.mem all_blocks filename then Hashtbl.find all_blocks filename
else
let number = !next_number in
incr next_number;
let b = { filename; number } in
Hashtbl.add all_blocks filename b;
b
in
b
let xen_block_packages =
[ package ~min:"2.1.0" ~max:"3.0.0" ~sublibs:[ "front" ] "mirage-block-xen" ]
(* this function takes a string rather than an int as `id` to allow
the user to pass stuff like "/dev/xvdi1", which mirage-block-xen
also understands *)
let xenstore_conf id =
let configure i =
match Misc.get_target i with
| `Qubes | `Xen -> ok ()
| _ ->
error
"XenStore IDs are only valid ways of specifying block devices when \
the target is Xen or Qubes."
in
let connect _ impl_name _ = code ~pos:__POS__ "%s.connect %S" impl_name id in
impl ~configure ~connect ~packages:xen_block_packages "Block" block
let block_of_xenstore_id id = xenstore_conf id
(* calculate the XenStore ID for the nth available block device.
Taken from https://github.com/mirage/mirage-block-xen/blob/
a64d152586c7ebc1d23c5adaa4ddd440b45a3a83/lib/device_number.ml#L64 . *)
let xenstore_id_of_index number =
if number < 16 then (202 lsl 8) lor (number lsl 4)
else (1 lsl 28) lor (number lsl 8)
let block_conf file =
let connect_name target =
match target with
| #Key.mode_unix -> file (* open the file directly *)
| #Key.mode_xen ->
let b = make_block_t file in
xenstore_id_of_index b.number |> string_of_int
| #Key.mode_solo5 ->
(* XXX For now, on Solo5, just pass the "file" name through directly as
* the Solo5 block device name *)
file
| #Key.mode_unikraft -> file
in
let packages_v =
Key.match_ Key.(value target) @@ function
| #Key.mode_xen -> xen_block_packages
| #Key.mode_solo5 ->
[ package ~min:"0.8.0" ~max:"0.9.0" "mirage-block-solo5" ]
| #Key.mode_unix ->
[ package ~min:"2.12.0" ~max:"3.0.0" "mirage-block-unix" ]
| #Key.mode_unikraft ->
[ package ~min:"1.0.0" ~max:"2.0.0" "mirage-block-unikraft" ]
in
let configure _ =
let (_ : block_t) = make_block_t file in
ok ()
in
let connect i s _ =
match Misc.get_target i with
| `Muen -> failwith "Block devices not supported on Muen target."
| _ ->
code ~pos:__POS__ "%s.connect %S" s (connect_name (Misc.get_target i))
in
Functoria.Device.v ~configure ~packages_v ~connect "Block" block
let block_of_file file = of_device (block_conf file)
let ramdisk rname =
let packages = [ package "mirage-block-ramdisk" ] in
let connect _ m _ = code ~pos:__POS__ "%s.connect ~name:%S" m rname in
impl ~connect ~packages "Ramdisk" block
let generic_block ?group ?(key = Key.(value @@ block ?group ())) name =
match_impl key
[
(`XenstoreId, block_of_xenstore_id name);
(`BlockFile, block_of_file name);
(`Ramdisk, ramdisk name);
]
~default:(ramdisk name)
let tar_kv_ro_conf =
let packages = [ package ~min:"1.0.0" ~max:"4.0.0" "tar-mirage" ] in
let connect _ modname = function
| [ block ] -> code ~pos:__POS__ "%s.connect %s" modname block
| _ -> Misc.connect_err "tar_kv_ro" 1
in
impl ~packages ~connect "Tar_mirage.Make_KV_RO" (block @-> Kv.ro)
let tar_kv_rw_conf =
let packages = [ package ~min:"2.2.0" ~max:"4.0.0" "tar-mirage" ] in
let connect _ modname = function
| [ block ] -> code ~pos:__POS__ "%s.connect %s" modname block
| _ -> Misc.connect_err "tar_kv_rw" 1
in
impl ~packages ~connect "Tar_mirage.Make_KV_RW" (block @-> Kv.rw)
let tar_kv_ro block = tar_kv_ro_conf $ block
let tar_kv_rw block = tar_kv_rw_conf $ block
let fat_conf =
let packages = [ package ~min:"0.15.0" ~max:"0.16.0" "fat-filesystem" ] in
let connect _ modname = function
| [ block ] -> code ~pos:__POS__ "%s.connect %s" modname block
| _ -> Misc.connect_err "fat" 1
in
impl ~packages ~connect "Fat.KV_RO" (block @-> Kv.ro)
let fat_ro block = fat_conf $ block
type mode = [ `Fast | `Light ]
let pp_mode ppf = function
| `Fast -> Fmt.string ppf "Fast"
| `Light -> Fmt.string ppf "Light"
let pp_branch ppf = function
| None -> ()
| Some branch -> Fmt.pf ppf " -b %s" branch
let docteur_unix (mode : mode) extra_deps ~name:_ ~output branch analyze remote
=
let dune info =
let ctx = Info.context info in
let output = Key.get ctx output in
let source_tree =
let uri = Uri.of_string remote in
match Uri.scheme uri with
| Some "file" ->
let path = Uri.host_with_default ~default:"" uri ^ Uri.path uri in
Fmt.str " (source_tree /%s)" path
| Some "relativize" ->
let path = Uri.host_with_default ~default:"" uri ^ Uri.path uri in
Fmt.str " (source_tree %s)" path
| _ -> ""
in
let dune =
Dune.stanzaf
{dune|
(rule
(targets %s)
(enabled_if (= %%{context_name} "default"))
(deps (:make %%{bin:docteur.make})%a%s)
(action (run %%{make} %s%a %s)))
|dune}
output
Fmt.(list ~sep:nop (const string " " ++ string))
extra_deps source_tree remote pp_branch branch output
in
[ dune ]
in
let install info =
let ctx = Info.context info in
let output = Fpath.v (Key.get ctx output) in
Install.v ~etc:[ output ] ()
in
let configure info =
let ctx = Info.context info in
let name = Key.get ctx output in
let (_ : block_t) = make_block_t name in
ok ()
in
let connect info modname = function
| [ analyze ] ->
let ctx = Info.context info in
let name = Key.get ctx output in
code ~pos:__POS__
{ocaml|let ( <.> ) f g = fun x -> f (g x) in
let f = Rresult.R.(failwith_error_msg <.> reword_error (msgf "%%a" %s.pp_error)) in
Lwt.map f (%s.connect ~analyze:%s %S)|ocaml}
modname modname analyze name
| _ -> Misc.connect_err "docteur_unix" 1
in
let keys = [ Key.v output ] in
let runtime_args = Runtime_arg.[ v analyze ] in
let packages = [ package "docteur-unix" ~min:"0.0.6" ] in
impl ~runtime_args ~keys ~packages ~dune ~install ~configure ~connect
(Fmt.str "Docteur_unix.%a" pp_mode mode)
Kv.ro
let docteur_solo5 (mode : mode) extra_deps ~name ~output branch analyze remote =
let dune info =
let ctx = Info.context info in
let output = Key.get ctx output in
let source_tree =
let uri = Uri.of_string remote in
match Uri.scheme uri with
| Some "file" ->
let path = Uri.host_with_default ~default:"" uri ^ Uri.path uri in
Fmt.str " (source_tree /%s)" path
| Some "relativize" ->
let path = Uri.host_with_default ~default:"" uri ^ Uri.path uri in
Fmt.str " (source_tree %s)" path
| _ -> ""
in
let dune =
Dune.stanzaf
{dune|
(rule
(targets %s)
(enabled_if (= %%{context_name} "default"))
(deps (:make %%{bin:docteur.make})%a%s)
(action (run %%{make} %s%a %s)))
|dune}
output
Fmt.(list ~sep:nop (const string " " ++ string))
extra_deps source_tree remote pp_branch branch output
in
[ dune ]
in
let install info =
let ctx = Info.context info in
let output = Fpath.v (Key.get ctx output) in
Install.v ~etc:[ output ] ()
in
let configure info =
let ctx = Info.context info in
let name = Key.get ctx name in
let (_ : block_t) = make_block_t name in
ok ()
in
let connect info modname = function
| [ analyze ] ->
let ctx = Info.context info in
let name = Key.get ctx name in
code ~pos:__POS__
{ocaml|let ( <.> ) f g = fun x -> f (g x) in
let f = Rresult.R.(failwith_error_msg <.> reword_error (msgf "%%a" %s.pp_error)) in
Lwt.map f (%s.connect ~analyze:%s %S)|ocaml}
modname modname analyze name
| _ -> Misc.connect_err "docteur_solo5" 1
in
let keys = [ Key.v output; Key.v name ] in
let runtime_args = Runtime_arg.[ v analyze ] in
let packages = [ package "docteur-solo5" ~min:"0.0.6" ] in
impl ~keys ~runtime_args ~packages ~dune ~install ~configure ~connect
(Fmt.str "Docteur_solo5.%a" pp_mode mode)
Kv.ro
let disk_name =
let doc =
Cmdliner.Arg.info
~doc:
"Name of the docteur disk (for Solo5 targets, the name must contains \
only alpanumeric characters)."
[ "disk-name" ]
in
let key = Key.Arg.opt Cmdliner.Arg.string "docteur" doc in
Key.create "disk-name" key
let disk_output =
let doc =
Cmdliner.Arg.info ~doc:"The output of the generated docteur image."
[ "disk-output" ]
in
let key = Key.Arg.opt Cmdliner.Arg.string "disk.img" doc in
Key.create "disk-output" key
let docteur_solo5 (mode : mode) extra_deps ?(name = disk_name)
?(output = disk_output) branch analyze remote =
docteur_solo5 mode extra_deps ~name ~output branch analyze remote
let docteur_unix (mode : mode) extra_deps ?(name = disk_name)
?(output = disk_output) branch analyze remote =
docteur_unix mode extra_deps ~name ~output branch analyze remote
let analyze = Runtime_arg.create ~pos:__POS__ "Mirage_runtime.analyze"
let docteur ?(mode = `Fast) ?name ?output ?(analyze = analyze) ?branch
?(extra_deps = []) remote =
match_impl
Key.(value target)
[
(`Xen, docteur_solo5 mode extra_deps ?name ?output branch analyze remote);
(`Qubes, docteur_solo5 mode extra_deps ?name ?output branch analyze remote);
( `Virtio,
docteur_solo5 mode extra_deps ?name ?output branch analyze remote );
(`Hvt, docteur_solo5 mode extra_deps ?name ?output branch analyze remote);
(`Spt, docteur_solo5 mode extra_deps ?name ?output branch analyze remote);
(`Muen, docteur_solo5 mode extra_deps ?name ?output branch analyze remote);
( `Genode,
docteur_solo5 mode extra_deps ?name ?output branch analyze remote );
]
~default:(docteur_unix mode extra_deps ?name ?output branch analyze remote)
let chamelon ~program_block_size =
let runtime_args = Runtime_arg.[ v program_block_size ] in
let packages = [ package "chamelon" ~sublibs:[ "kv" ] ~min:"0.0.8" ] in
let connect _ modname = function
| [ block; program_block_size ] ->
code ~pos:__POS__
{ocaml|%s.connect ~program_block_size:%s %s
>|= Result.map_error (Fmt.str "%%a" %s.pp_error)
>|= Result.fold ~ok:Fun.id ~error:failwith|ocaml}
modname program_block_size block modname
| _ -> Misc.connect_err "chameleon" 2
in
impl ~packages ~runtime_args ~connect "Kv.Make" (block @-> Kv.rw)
let ccm_block ?nonce_len key =
let runtime_args = Runtime_arg.[ v key ] in
let packages = [ package "mirage-block-ccm" ~min:"2.0.0" ~max:"3.0.0" ] in
let connect _ modname = function
| [ block; key ] ->
code ~pos:__POS__
{ocaml|let key = %s in
let key =
if String.length key >= 2 && String.(equal "0x" (sub key 0 2)) then
String.sub key 2 (String.length key - 2)
else
key
in
%s.connect ?nonce_len:%a ~key:(Cstruct.of_hex key) %s|ocaml}
key modname
Fmt.(parens (Dump.option int))
nonce_len block
| _ -> Misc.connect_err "ccm_block" 2
in
impl ~packages ~runtime_args ~connect "Block_ccm.Make" (block @-> block)

37
unikernel/duniverse/mirage/lib/devices/block.mli Normal file
View file

@ -0,0 +1,37 @@
open Functoria.DSL
type block
val block : block typ
val generic_block :
?group:string ->
?key:[ `BlockFile | `Ramdisk | `XenstoreId ] value ->
string ->
block impl
val tar_kv_ro : block impl -> Kv.ro impl
val fat_ro : block impl -> Kv.ro impl
val ramdisk : string -> block impl
val block_of_xenstore_id : string -> block impl
val block_of_file : string -> block impl
val block_conf : string -> block device
val docteur :
?mode:[ `Fast | `Light ] ->
?name:string key ->
?output:string key ->
?analyze:bool runtime_arg ->
?branch:string ->
?extra_deps:string list ->
string ->
Kv.ro impl
type block_t = { filename : string; number : int }
val all_blocks : (string, block_t) Hashtbl.t
val chamelon : program_block_size:int runtime_arg -> (block -> Kv.rw) impl
val tar_kv_rw : block impl -> Kv.rw impl
val ccm_block :
?nonce_len:int -> string option runtime_arg -> (block -> block) impl

25
unikernel/duniverse/mirage/lib/devices/conduit.ml Normal file
View file

@ -0,0 +1,25 @@
open Functoria.DSL
type conduit = Conduit
let conduit = typ Conduit
let pkg = package ~min:"8.0.0" ~max:"9.0.0" "conduit-mirage"
let tcp =
let packages = [ pkg ] in
let connect _ _ = function
| [ stack ] -> code ~pos:__POS__ "Lwt.return %s@;" stack
| _ -> Misc.connect_err "tcp_conduit" 1
in
impl ~packages ~connect "Conduit_mirage.TCP" (Stack.stackv4v6 @-> conduit)
let tls =
let packages = [ pkg; package ~min:"2.0.0" ~max:"3.0.0" "tls-mirage" ] in
let connect _ _ = function
| [ stack ] -> code ~pos:__POS__ "Lwt.return %s@;" stack
| _ -> Misc.connect_err "tls_conduit" 1
in
impl ~packages ~connect "Conduit_mirage.TLS" (conduit @-> conduit)
let conduit_direct ?tls:(use_tls = false) s =
if use_tls then tls $ (tcp $ s) else tcp $ s

7
unikernel/duniverse/mirage/lib/devices/conduit.mli Normal file
View file

@ -0,0 +1,7 @@
open Functoria.DSL
type conduit
val pkg : package
val conduit : conduit typ
val conduit_direct : ?tls:bool -> Stack.stackv4v6 impl -> conduit impl

21
unikernel/duniverse/mirage/lib/devices/dns.ml Normal file
View file

@ -0,0 +1,21 @@
open Functoria.DSL
type dns_client = Dns_client
let dns_client = typ Dns_client
let generic_dns_client ?group ?timeout ?nameservers ?cache_size () =
let packages = [ package "dns-client-mirage" ~min:"10.0.0" ~max:"11.0.0" ] in
let nameservers = Runtime_arg.dns_servers ?group nameservers
and timeout = Runtime_arg.dns_timeout ?group timeout
and cache_size = Runtime_arg.dns_cache_size ?group cache_size in
let runtime_args = Runtime_arg.[ v nameservers; v timeout; v cache_size ] in
let connect _info modname = function
| [ stackv4v6; happy_eyeballs; nameservers; timeout; cache_size ] ->
code ~pos:__POS__
{ocaml|%s.connect @[?nameservers:%s ?timeout:%s ?cache_size:%s@ (%s, %s)@]|ocaml}
modname nameservers timeout cache_size stackv4v6 happy_eyeballs
| _ -> Misc.connect_err "generic_dns_client" 5
in
impl ~runtime_args ~packages ~connect "Dns_client_mirage.Make"
(Stack.stackv4v6 @-> Happy_eyeballs.happy_eyeballs @-> dns_client)

13
unikernel/duniverse/mirage/lib/devices/dns.mli Normal file
View file

@ -0,0 +1,13 @@
open Functoria.DSL
type dns_client
val dns_client : dns_client typ
val generic_dns_client :
?group:string ->
?timeout:int64 ->
?nameservers:string list ->
?cache_size:int ->
unit ->
(Stack.stackv4v6 -> Happy_eyeballs.happy_eyeballs -> dns_client) impl

4
unikernel/duniverse/mirage/lib/devices/dune Normal file
View file

@ -0,0 +1,4 @@
(library
(name devices)
(public_name mirage.devices)
(libraries mirage.functoria))

15
unikernel/duniverse/mirage/lib/devices/ethernet.ml Normal file
View file

@ -0,0 +1,15 @@
open Functoria.DSL
type ethernet = ETHERNET
let ethernet = typ ETHERNET
let ethif_conf =
let packages = [ package ~min:"3.0.0" ~max:"4.0.0" "ethernet" ] in
let connect _ m = function
| [ eth ] -> code ~pos:__POS__ "%s.connect %s" m eth
| _ -> Misc.connect_err "etif" 1
in
impl ~packages ~connect "Ethernet.Make" (Network.network @-> ethernet)
let ethif network = ethif_conf $ network

6
unikernel/duniverse/mirage/lib/devices/ethernet.mli Normal file
View file

@ -0,0 +1,6 @@
open Functoria.DSL
type ethernet
val ethernet : ethernet typ
val ethif : Network.network impl -> ethernet impl

55
unikernel/duniverse/mirage/lib/devices/git.ml Normal file
View file

@ -0,0 +1,55 @@
open Functoria.DSL
type git_client = Git_client
let git_client = typ Git_client
let git_merge_clients =
let packages = [ package "mimic" ] in
let connect _ _modname = function
| [ a; b ] -> code ~pos:__POS__ "Lwt.return (Mimic.merge %s %s)" a b
| _ -> Misc.connect_err "git_merge_client" 2
in
impl ~packages ~connect "Mimic.Merge"
(git_client @-> git_client @-> git_client)
let git_tcp =
let packages = [ package ~max:"1.0.0" "git-net" ] in
let connect _ modname = function
| [ _tcpv4v6; ctx ] ->
code ~pos:__POS__ {ocaml|%s.connect %s|ocaml} modname ctx
| _ -> Misc.connect_err "git_tcp" 2
in
impl ~packages ~connect "Git_net.TCP.Make"
(Tcp.tcpv4v6 @-> Mimic.mimic @-> git_client)
let git_ssh ?group ?authenticator ?key ?password () =
let packages = [ package ~max:"1.0.0" "git-net" ] in
let key = Runtime_arg.ssh_key ?group key
and password = Runtime_arg.ssh_password ?group password
and authenticator = Runtime_arg.ssh_authenticator ?group authenticator in
let runtime_args = Runtime_arg.[ v key; v password; v authenticator ] in
let connect _ modname = function
| [ _tcpv4v6; ctx; key; password; authenticator ] ->
code ~pos:__POS__
{ocaml|%s.connect %s >>= %s.with_optionnal_key ?authenticator:%s ~key:%s ~password:%s|ocaml}
modname ctx modname authenticator key password
| _ -> Misc.connect_err "git_ssh" 5
in
impl ~packages ~connect ~runtime_args "Git_net.SSH.Make"
(Tcp.tcpv4v6 @-> Mimic.mimic @-> git_client)
let git_http ?group ?authenticator ?headers () =
let packages = [ package ~max:"1.0.0" "git-net" ] in
let authenticator = Runtime_arg.tls_authenticator ?group authenticator
and headers = Runtime_arg.http_headers ?group headers in
let runtime_args = Runtime_arg.[ v authenticator; v headers ] in
let connect _ modname = function
| [ _tcpv4v6; ctx; authenticator; headers ] ->
code ~pos:__POS__
{ocaml|%s.connect %s >>= %s.with_optional_tls_config_and_headers ?headers:%s ?authenticator:%s|ocaml}
modname ctx modname headers authenticator
| _ -> Misc.connect_err "git_http" 4
in
impl ~packages ~connect ~runtime_args "Git_net.HTTP.Make"
(Tcp.tcpv4v6 @-> Mimic.mimic @-> git_client)

22
unikernel/duniverse/mirage/lib/devices/git.mli Normal file
View file

@ -0,0 +1,22 @@
open Functoria.DSL
type git_client
val git_client : git_client typ
val git_merge_clients : (git_client -> git_client -> git_client) impl
val git_tcp : (Tcp.tcpv4v6 -> Mimic.mimic -> git_client) impl
val git_ssh :
?group:string ->
?authenticator:string ->
?key:string ->
?password:string ->
unit ->
(Tcp.tcpv4v6 -> Mimic.mimic -> git_client) impl
val git_http :
?group:string ->
?authenticator:string ->
?headers:(string * string) list ->
unit ->
(Tcp.tcpv4v6 -> Mimic.mimic -> git_client) impl

47
unikernel/duniverse/mirage/lib/devices/happy_eyeballs.ml Normal file
View file

@ -0,0 +1,47 @@
open Functoria.DSL
type happy_eyeballs = Happy_eyeballs
let happy_eyeballs = typ Happy_eyeballs
let generic_happy_eyeballs ?group ?aaaa_timeout ?connect_delay ?connect_timeout
?resolve_timeout ?resolve_retries ?timer_interval () =
let packages =
[ package "happy-eyeballs-mirage" ~min:"2.0.0" ~max:"3.0.0" ]
in
let aaaa_timeout = Runtime_arg.he_aaaa_timeout ?group aaaa_timeout
and connect_delay = Runtime_arg.he_connect_delay ?group connect_delay
and connect_timeout = Runtime_arg.he_connect_timeout ?group connect_timeout
and resolve_timeout = Runtime_arg.he_resolve_timeout ?group resolve_timeout
and resolve_retries = Runtime_arg.he_resolve_retries ?group resolve_retries
and timer_interval = Runtime_arg.he_timer_interval ?group timer_interval in
let runtime_args =
Runtime_arg.
[
v aaaa_timeout;
v connect_delay;
v connect_timeout;
v resolve_timeout;
v resolve_retries;
v timer_interval;
]
in
let connect _info modname = function
| [
stack;
aaaa_timeout;
connect_delay;
connect_timeout;
resolve_timeout;
resolve_retries;
timer_interval;
] ->
code ~pos:__POS__
{ocaml|%s.connect_device ?aaaa_timeout:%s ?connect_delay:%s
?connect_timeout:%s ?resolve_timeout:%s ?resolve_retries:%s ?timer_interval:%s %s|ocaml}
modname aaaa_timeout connect_delay connect_timeout resolve_timeout
resolve_retries timer_interval stack
| _ -> Misc.connect_err "generic_happy_eyeballs" 7
in
impl ~runtime_args ~packages ~connect "Happy_eyeballs_mirage.Make"
(Stack.stackv4v6 @-> happy_eyeballs)

16
unikernel/duniverse/mirage/lib/devices/happy_eyeballs.mli Normal file
View file

@ -0,0 +1,16 @@
open Functoria.DSL
type happy_eyeballs
val happy_eyeballs : happy_eyeballs typ
val generic_happy_eyeballs :
?group:string ->
?aaaa_timeout:int64 ->
?connect_delay:int64 ->
?connect_timeout:int64 ->
?resolve_timeout:int64 ->
?resolve_retries:int ->
?timer_interval:int64 ->
unit ->
(Stack.stackv4v6 -> happy_eyeballs) impl

69
unikernel/duniverse/mirage/lib/devices/http.ml Normal file
View file

@ -0,0 +1,69 @@
open Functoria.DSL
type http = HTTP
let http = typ HTTP
type http_client = HTTP_client
let http_client = typ HTTP_client
let connect err _i modname = function
| [ conduit ] -> code ~pos:__POS__ "Lwt.return (%s.listen %s)" modname conduit
| _ -> Misc.connect_err err 1
let cohttp_server =
let packages = [ package ~min:"6.1.0" ~max:"7.0.0" "cohttp-mirage" ] in
impl ~packages ~connect:(connect "http") "Cohttp_mirage.Server.Make"
(Conduit.conduit @-> http)
let cohttp_server conduit = cohttp_server $ conduit
let cohttp_client =
let packages = [ package ~min:"6.1.0" ~max:"7.0.0" "cohttp-mirage" ] in
let connect _i modname = function
| [ resolver; conduit ] ->
code ~pos:__POS__ "Lwt.return (%s.ctx %s %s)" modname resolver conduit
| _ -> Misc.connect_err "http" 2
in
impl ~packages ~connect "Cohttp_mirage.Client.Make"
(Resolver.resolver @-> Conduit.conduit @-> http_client)
let cohttp_client resolver conduit = cohttp_client $ resolver $ conduit
let httpaf_server conduit =
let packages = [ package "httpaf-mirage" ] in
let extra_deps = [ dep conduit ] in
impl ~packages ~connect:(connect "httpaf") ~extra_deps
"Httpaf_mirage.Server_with_conduit" http
type http_server = HTTP_server
let http_server = typ HTTP_server
let paf_server port =
let connect _ modname = function
| [ tcpv4v6; port ] ->
code ~pos:__POS__ {ocaml|%s.init ~port:%s %s|ocaml} modname port tcpv4v6
| _ -> Misc.connect_err "paf_server" 2
in
let packages =
[ package "paf" ~sublibs:[ "mirage" ] ~min:"0.8.0" ~max:"0.9.0" ]
in
let runtime_args = Runtime_arg.[ v port ] in
impl ~connect ~packages ~runtime_args "Paf_mirage.Make"
(Tcp.tcpv4v6 @-> http_server)
type alpn_client = ALPN_client
let alpn_client = typ ALPN_client
let paf_client =
let packages = [ package "http-mirage-client" ~min:"0.0.9" ~max:"0.1.0" ] in
let connect _ modname = function
| [ _tcpv4v6; ctx ] ->
code ~pos:__POS__ {ocaml|%s.connect %s|ocaml} modname ctx
| _ -> Misc.connect_err "paf_client" 2
in
impl ~connect ~packages "Http_mirage_client.Make"
(Tcp.tcpv4v6 @-> Mimic.mimic @-> alpn_client)

24
unikernel/duniverse/mirage/lib/devices/http.mli Normal file
View file

@ -0,0 +1,24 @@
open Functoria.DSL
type http
val http : http typ
val cohttp_server : Conduit.conduit impl -> http impl
val httpaf_server : Conduit.conduit impl -> http impl
type http_client
val http_client : http_client typ
val cohttp_client :
Resolver.resolver impl -> Conduit.conduit impl -> http_client impl
type http_server
val http_server : http_server typ
val paf_server : int runtime_arg -> (Tcp.tcpv4v6 -> http_server) impl
type alpn_client
val alpn_client : alpn_client typ
val paf_client : (Tcp.tcpv4v6 -> Mimic.mimic -> alpn_client) impl

17
unikernel/duniverse/mirage/lib/devices/icmp.ml Normal file
View file

@ -0,0 +1,17 @@
open Functoria.DSL
type 'a icmp = ICMP
type icmpv4 = Ip.v4 icmp
let icmp = typ ICMP
let icmpv4 : icmpv4 typ = icmp
let icmpv4_direct () =
let packages_v = Ip.right_tcpip_library ~sublibs:[ "icmpv4" ] "tcpip" in
let connect _ modname = function
| [ ip ] -> code ~pos:__POS__ "%s.connect %s" modname ip
| _ -> Misc.connect_err "icmpv4" 1
in
impl ~packages_v ~connect "Icmpv4.Make" (Ip.ip @-> icmp)
let direct_icmpv4 ip = icmpv4_direct () $ ip

6
unikernel/duniverse/mirage/lib/devices/icmp.mli Normal file
View file

@ -0,0 +1,6 @@
open Functoria.DSL
type icmpv4
val icmpv4 : icmpv4 typ
val direct_icmpv4 : Ip.ipv4 impl -> icmpv4 impl

122
unikernel/duniverse/mirage/lib/devices/ip.ml Normal file
View file

@ -0,0 +1,122 @@
open Functoria.DSL
type v4
type v6
type v4v6
type 'a ip = IP
type ipv4 = v4 ip
type ipv6 = v6 ip
type ipv4v6 = v4v6 ip
let ip = Functoria.Type.Type IP
let ipv4 : ipv4 typ = ip
let ipv6 : ipv6 typ = ip
let ipv4v6 : ipv4v6 typ = ip
(* convenience function for linking tcpip.unix for checksums *)
let right_tcpip_library ?libs ~sublibs pkg =
let min = "9.0.0" and max = "10.0.0" in
Key.pure [ package ~min ~max ?libs ~sublibs pkg ]
let ipv4_keyed_conf ~ip ~gateway ~no_init () =
let packages_v = right_tcpip_library ~sublibs:[ "ipv4" ] "tcpip" in
let runtime_args = Runtime_arg.[ v ip; v gateway; v no_init ] in
let connect _ modname = function
| [ etif; arp; ip; gateway; no_init ] ->
code ~pos:__POS__
"%s.connect@[~no_init:%s@ ~cidr:%s@ ?gateway:%s@ %s@ %s@]" modname
no_init ip gateway etif arp
| _ -> Misc.connect_err "ipv4 keyed" 5
in
impl ~packages_v ~runtime_args ~connect "Static_ipv4.Make"
(Ethernet.ethernet @-> Arp.arpv4 @-> ipv4)
let ipv4_dhcp_conf =
let packages =
[ package ~min:"2.0.0" ~max:"3.0.0" ~sublibs:[ "mirage" ] "charrua-client" ]
in
let connect _ modname = function
| [ network; ethernet; arp ] ->
code ~pos:__POS__ "%s.connect@[@ %s@ %s@ %s@]" modname network ethernet
arp
| _ -> Misc.connect_err "ipv4 dhcp" 3
in
impl ~packages ~connect "Dhcp_ipv4.Make"
(Network.network @-> Ethernet.ethernet @-> Arp.arpv4 @-> ipv4)
let ipv4_of_dhcp net ethif arp = ipv4_dhcp_conf $ net $ ethif $ arp
let keyed_create_ipv4 ?group
?(network = Ipaddr.V4.Prefix.of_string_exn "10.0.0.2/24") ?gateway ~no_init
etif arp =
let ip = Runtime_arg.V4.network ?group network
and gateway = Runtime_arg.V4.gateway ?group gateway in
ipv4_keyed_conf ~ip ~gateway ~no_init () $ etif $ arp
let create_ipv4 ?group etif arp =
let network, gateway = (Ipaddr.V4.Prefix.of_string_exn "10.0.0.2/24", None) in
let ip = Runtime_arg.V4.network ?group network
and gateway = Runtime_arg.V4.gateway ?group gateway
and no_init = Runtime_arg.ipv6_only ?group () in
ipv4_keyed_conf ~ip ~gateway ~no_init () $ etif $ arp
let ipv4_qubes_conf =
let packages = [ package ~min:"2.0.0" ~max:"3.0.0" "mirage-qubes-ipv4" ] in
let connect _ modname = function
| [ db; etif; arp ] ->
code ~pos:__POS__ "%s.connect@[@ %s@ %s@ %s@]" modname db etif arp
| _ -> Misc.connect_err "qubes_ipv4" 3
in
impl ~packages ~connect "Qubesdb_ipv4.Make"
(Qubesdb.qubesdb @-> Ethernet.ethernet @-> Arp.arpv4 @-> ipv4)
let ipv4_qubes db ethernet arp = ipv4_qubes_conf $ db $ ethernet $ arp
let ipv6_conf ~ip ~gateway ~handle_ra ~no_init () =
let packages_v = right_tcpip_library ~sublibs:[ "ipv6" ] "tcpip" in
let runtime_args = Runtime_arg.[ v ip; v gateway; v handle_ra; v no_init ] in
let connect _ modname = function
| [ netif; etif; ip; gateway; handle_ra; no_init ] ->
code ~pos:__POS__
"%s.connect@[~no_init:%s@ ~handle_ra:%s@ ?cidr:%s@ ?gateway:%s@ %s@ \
%s@]"
modname no_init handle_ra ip gateway netif etif
| _ -> Misc.connect_err "ipv6" 6
in
impl ~packages_v ~runtime_args ~connect "Ipv6.Make"
(Network.network @-> Ethernet.ethernet @-> ipv6)
let keyed_create_ipv6 ?group ?network ?gateway ~no_init netif etif =
let ip = Runtime_arg.V6.network ?group network
and gateway = Runtime_arg.V6.gateway ?group gateway
and handle_ra = Runtime_arg.V6.accept_router_advertisements ?group () in
ipv6_conf ~ip ~gateway ~handle_ra ~no_init () $ netif $ etif
let create_ipv6 ?group netif etif =
let network, gateway = (None, None) in
let ip = Runtime_arg.V6.network ?group network
and gateway = Runtime_arg.V6.gateway ?group gateway
and handle_ra = Runtime_arg.V6.accept_router_advertisements ?group ()
and no_init = Runtime_arg.ipv4_only ?group () in
ipv6_conf ~ip ~gateway ~handle_ra ~no_init () $ netif $ etif
let ipv4v6_conf ~ipv4_only ~ipv6_only () =
let packages_v = right_tcpip_library ~sublibs:[ "stack-direct" ] "tcpip" in
let runtime_args = [ Runtime_arg.v ipv4_only; Runtime_arg.v ipv6_only ] in
let connect _ modname = function
| [ ipv4; ipv6; ipv4_only; ipv6_only ] ->
code ~pos:__POS__ "%s.connect@[@ ~ipv4_only:%s@ ~ipv6_only:%s@ %s@ %s@]"
modname ipv4_only ipv6_only ipv4 ipv6
| _ -> Misc.connect_err "ipv4v6" 4
in
impl ~packages_v ~runtime_args ~connect "Tcpip_stack_direct.IPV4V6"
(ipv4 @-> ipv6 @-> ipv4v6)
let keyed_ipv4v6 ~ipv4_only ~ipv6_only ipv4 ipv6 =
ipv4v6_conf ~ipv4_only ~ipv6_only () $ ipv4 $ ipv6
let create_ipv4v6 ?group ipv4 ipv6 =
let ipv4_only = Runtime_arg.ipv4_only ?group ()
and ipv6_only = Runtime_arg.ipv6_only ?group () in
keyed_ipv4v6 ~ipv4_only ~ipv6_only ipv4 ipv6

56
unikernel/duniverse/mirage/lib/devices/ip.mli Normal file
View file

@ -0,0 +1,56 @@
open Functoria.DSL
type v4
type v6
type v4v6
type 'a ip
type ipv4 = v4 ip
type ipv6 = v6 ip
type ipv4v6 = v4v6 ip
val ip : 'a ip typ
val ipv4 : ipv4 typ
val ipv6 : ipv6 typ
val ipv4v6 : ipv4v6 typ
val create_ipv4 :
?group:string -> Ethernet.ethernet impl -> Arp.arpv4 impl -> ipv4 impl
val keyed_create_ipv4 :
?group:string ->
?network:Ipaddr.V4.Prefix.t ->
?gateway:Ipaddr.V4.t ->
no_init:bool runtime_arg ->
Ethernet.ethernet impl ->
Arp.arpv4 impl ->
ipv4 impl
val create_ipv6 :
?group:string -> Network.network impl -> Ethernet.ethernet impl -> ipv6 impl
val keyed_create_ipv6 :
?group:string ->
?network:Ipaddr.V6.Prefix.t ->
?gateway:Ipaddr.V6.t ->
no_init:bool runtime_arg ->
Network.network impl ->
Ethernet.ethernet impl ->
ipv6 impl
val ipv4_of_dhcp :
Network.network impl -> Ethernet.ethernet impl -> Arp.arpv4 impl -> ipv4 impl
val ipv4_qubes :
Qubesdb.qubesdb impl -> Ethernet.ethernet impl -> Arp.arpv4 impl -> ipv4 impl
val create_ipv4v6 : ?group:string -> ipv4 impl -> ipv6 impl -> ipv4v6 impl
val keyed_ipv4v6 :
ipv4_only:bool runtime_arg ->
ipv6_only:bool runtime_arg ->
ipv4 impl ->
ipv6 impl ->
ipv4v6 impl
val right_tcpip_library :
?libs:string list -> sublibs:string list -> string -> package list value

156
unikernel/duniverse/mirage/lib/devices/key.ml Normal file
View file

@ -0,0 +1,156 @@
(*
* Copyright (c) 2015 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.
*)
module Action = Functoria.Action
module Key = Functoria.Key
(** {2 Documentation helper} *)
let mirage_section = "MIRAGE PARAMETERS"
let unikernel_section = "UNIKERNEL PARAMETERS"
let pp_group = Fmt.(option ~none:(any "the unikernel") @@ fmt "the %s group")
(** {2 Special keys} *)
(** {3 Mode} *)
type mode_unix = [ `Unix | `MacOSX ]
type mode_xen = [ `Xen | `Qubes ]
type mode_solo5 = [ `Hvt | `Spt | `Virtio | `Muen | `Genode ]
type mode_unikraft = [ `Firecracker | `QEMU ]
type mode = [ mode_unix | mode_xen | mode_solo5 | mode_unikraft ]
let (target_conv : mode Cmdliner.Arg.conv), target_doc_alts =
let enum =
[
("unix", `Unix);
("macosx", `MacOSX);
("xen", `Xen);
("virtio", `Virtio);
("hvt", `Hvt);
("muen", `Muen);
("qubes", `Qubes);
("genode", `Genode);
("spt", `Spt);
("unikraft-firecracker", `Firecracker);
("unikraft-qemu", `QEMU);
]
in
let conv = Cmdliner.Arg.enum enum in
(conv, Cmdliner.Arg.doc_alts_enum enum)
let pp_target fmt m = Cmdliner.Arg.conv_printer target_conv fmt m
let default_target =
match Sys.getenv "MIRAGE_DEFAULT_TARGET" with
| "unix" -> `Unix
| s -> Fmt.failwith "invalid default target: %S" s
| exception Not_found -> (
match Action.run @@ Action.run_cmd_out Bos.Cmd.(v "uname" % "-s") with
| Ok "Darwin" -> `MacOSX
| _ -> `Unix)
let target =
let doc =
Fmt.str "Target platform to compile the unikernel for. Valid values are: %s"
target_doc_alts
in
let doc =
Cmdliner.Arg.info ~docs:mirage_section ~docv:"TARGET" ~doc [ "t"; "target" ]
~env:(Cmdliner.Cmd.Env.info "MODE")
in
let key = Key.Arg.opt target_conv default_target doc in
Key.create "target" key
let is_unix =
Key.match_ Key.(value target) @@ function
| #mode_unix -> true
| #mode_xen | #mode_solo5 | #mode_unikraft -> false
let is_solo5 =
Key.match_ Key.(value target) @@ function
| #mode_solo5 -> true
| #mode_xen | #mode_unix | #mode_unikraft -> false
let is_xen =
Key.match_ Key.(value target) @@ function
| #mode_xen -> true
| #mode_solo5 | #mode_unix | #mode_unikraft -> false
let is_unikraft =
Key.match_ Key.(value target) @@ function
| #mode_unikraft -> true
| #mode_solo5 | #mode_unix | #mode_xen -> false
(** {2 General mirage keys} *)
let configure_key ?(group = "") ~doc ~default conv name =
let prefix = if group = "" then group else group ^ "-" in
let doc =
Cmdliner.Arg.info ~docs:unikernel_section
~docv:(String.uppercase_ascii name)
~doc
[ prefix ^ name ]
in
let key = Key.Arg.opt conv default doc in
Key.create (prefix ^ name) key
(** {3 File system keys} *)
let kv_ro ?group () =
let enum = [ ("crunch", `Crunch); ("direct", `Direct) ] in
let conv = Cmdliner.Arg.enum enum in
let doc =
Fmt.str "Use %s pass-through implementation for %a."
(Cmdliner.Arg.doc_alts_enum enum)
pp_group group
in
configure_key ~doc ?group ~default:`Crunch conv "kv_ro"
(** {3 Block device keys} *)
let block ?group () =
let enum =
[ ("xenstore", `XenstoreId); ("file", `BlockFile); ("ramdisk", `Ramdisk) ]
in
let conv = Cmdliner.Arg.enum enum in
let doc =
Fmt.str "Use %s pass-through implementation for %a."
(Cmdliner.Arg.doc_alts_enum enum)
pp_group group
in
configure_key ~doc ?group ~default:`Ramdisk conv "block"
(** {3 Stack keys} *)
let dhcp ?group () =
let doc = Fmt.str "Enable dhcp for %a." pp_group group in
configure_key ~doc ?group ~default:false Cmdliner.Arg.bool "dhcp"
let net ?group () : [ `Host | `OCaml ] option Key.key =
let enum =
[
("host", `Host); ("socket", `Host); ("direct", `OCaml); ("ocaml", `OCaml);
]
in
let conv = Cmdliner.Arg.enum enum in
let doc =
Fmt.str "Use %s group for %a."
(Cmdliner.Arg.doc_alts_enum enum)
pp_group group
in
configure_key ~doc ?group ~default:None (Cmdliner.Arg.some conv) "net"
include Key

76
unikernel/duniverse/mirage/lib/devices/key.mli Normal file
View file

@ -0,0 +1,76 @@
(*
* Copyright (c) 2015 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.
*)
(** Command-line arguments for the Mirage configuration tool. *)
include module type of Functoria.Key
type mode_unix = [ `Unix | `MacOSX ]
type mode_xen = [ `Xen | `Qubes ]
type mode_solo5 = [ `Hvt | `Spt | `Virtio | `Muen | `Genode ]
type mode_unikraft = [ `Firecracker | `QEMU ]
type mode = [ mode_unix | mode_xen | mode_solo5 | mode_unikraft ]
(** {2 Mirage keys} *)
val target : mode key
(** [-t TARGET]: Key setting the configuration mode for the current project. Is
one of ["unix"], ["macosx"], ["xen"], ["qubes"], ["virtio"], ["hvt"],
["muen"], ["genode"] or ["spt"]. *)
val pp_target : mode Fmt.t
(** Pretty printer for the mode. *)
val is_unix : bool value
(** Is true iff the {!target} key is a UNIXish system (["unix" or "macosx"]). *)
val is_solo5 : bool value
(** Is true iff the {!target} key is a Solo5-based target. *)
val is_xen : bool value
(** Is true iff the {!target} key is a Xen-based system (["xen" or "qubes"]). *)
val is_unikraft : bool value
(** Is true iff the {!target} key is a Unikraft-based target. *)
(** {2 Generic keys}
Some keys have a [group] optional argument. This group argument allows to
give several keys a prefix.
For example, if we have two [ip] stacks, one external and one internal, We
can use the [group] option to name them [in] and [out]. This way, the
available keys will be [--in-ip] and [--out-ip].
If a key has another, non-optional argument. It is the default value.
Keys are always named the same as their command line option. *)
(** {3 File system keys} *)
val kv_ro : ?group:string -> unit -> [ `Crunch | `Direct ] key
(** The type of key value store. Is one of ["crunch"], or ["direct"]. *)
val block : ?group:string -> unit -> [ `XenstoreId | `BlockFile | `Ramdisk ] key
(** {3 Block device keys} *)
(** {3 Stack keys} *)
val dhcp : ?group:string -> unit -> bool key
(** Enable dhcp. Is either [true] or [false]. *)
val net : ?group:string -> unit -> [ `OCaml | `Host ] option key
(** The type of stack. Is either ["ocaml"] or ["host"]. *)

86
unikernel/duniverse/mirage/lib/devices/kv.ml Normal file
View file

@ -0,0 +1,86 @@
module Dune = Functoria.Dune
open Functoria.DSL
type ro = RO
let ro = typ RO
let crunch dirname =
let is_valid = function
| '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' -> true
| _ -> false
in
let name =
let modname = String.map (fun c -> if is_valid c then c else '_') dirname in
"Static_" ^ String.lowercase_ascii modname
in
let packages =
[
package ~min:"4.0.0" ~max:"5.0.0" "mirage-kv-mem";
package ~min:"4.0.0" ~max:"5.0.0" ~build:true "crunch";
]
in
let connect _ modname _ = code ~pos:__POS__ "%s.connect ()" modname in
let dune _i =
let dir = Fpath.(v dirname) in
let file ext = Fpath.(v name + ext) in
let ml = file "ml" in
let mli = file "mli" in
let dune =
Dune.stanzaf
{|
(rule
(targets %a %a)
(deps (source_tree %a))
(action
(run ocaml-crunch -o %a %a)))
|}
Fpath.pp ml Fpath.pp mli Fpath.pp dir Fpath.pp ml Fpath.pp dir
in
[ dune ]
in
impl ~packages ~connect ~dune name ro
let direct_kv_ro dirname =
let packages = [ package ~min:"2.1.0" ~max:"3.0.0" "mirage-kv-unix" ] in
let connect _ modname _names =
code ~pos:__POS__ "%s.connect \"%s\"" modname dirname
in
impl ~packages ~connect "Mirage_kv_unix" ro
let direct_kv_ro dirname =
match_impl
Key.(value target)
[
(`Xen, crunch dirname);
(`Qubes, crunch dirname);
(`Virtio, crunch dirname);
(`Hvt, crunch dirname);
(`Spt, crunch dirname);
(`Muen, crunch dirname);
(`Genode, crunch dirname);
]
~default:(direct_kv_ro dirname)
type rw = RW
let rw = typ RW
let direct_kv_rw dirname =
let packages = [ package ~min:"2.1.0" ~max:"3.0.0" "mirage-kv-unix" ] in
let connect _ modname _names =
code ~pos:__POS__ "%s.connect \"%s\"" modname dirname
in
impl ~packages ~connect "Mirage_kv_unix" rw
let mem_kv_rw () =
let packages = [ package ~min:"3.0.0" ~max:"4.0.0" "mirage-kv-mem" ] in
let connect _ modname _names = code ~pos:__POS__ "%s.connect ()" modname in
impl ~packages ~connect "Mirage_kv_mem" rw
(** generic kv_ro. *)
let generic_kv_ro ?group ?(key = Key.value @@ Key.kv_ro ?group ()) dir =
match_impl key
[ (`Crunch, crunch dir); (`Direct, direct_kv_ro dir) ]
~default:(direct_kv_ro dir)

16
unikernel/duniverse/mirage/lib/devices/kv.mli Normal file
View file

@ -0,0 +1,16 @@
open Functoria.DSL
type ro
val ro : ro typ
val direct_kv_ro : string -> ro impl
val crunch : string -> ro impl
val generic_kv_ro :
?group:string -> ?key:[ `Crunch | `Direct ] value -> string -> ro impl
type rw
val rw : rw typ
val direct_kv_rw : string -> rw impl
val mem_kv_rw : unit -> rw impl

104
unikernel/duniverse/mirage/lib/devices/libvirt.ml Normal file
View file

@ -0,0 +1,104 @@
module Action = Functoria.Action
let filename ~name = Fpath.(v (name ^ "_libvirt") + "xml")
let append fmt s = Fmt.pf fmt (s ^^ "@.")
let configure_main ~name =
Action.with_output ~path:(filename ~name) ~purpose:"libvirt.xml" (fun fmt ->
append fmt "<domain type='xen'>";
append fmt " <name>%s</name>" name;
append fmt " <memory unit='KiB'>262144</memory>";
append fmt " <currentMemory unit='KiB'>262144</currentMemory>";
append fmt " <vcpu placement='static'>1</vcpu>";
append fmt " <os>";
append fmt " <type arch='armv7l' machine='xenpv'>linux</type>";
append fmt " <kernel>%s.xen</kernel>" name;
append fmt " <cmdline> </cmdline>";
(* the libxl driver currently needs an empty cmdline to be able to
start the domain on arm - due to this?
http://lists.xen.org/archives/html/xen-devel/2014-02/msg02375.html *)
append fmt " </os>";
append fmt " <clock offset='utc' adjustment='reset'/>";
append fmt " <on_crash>preserve</on_crash>";
append fmt " <!-- ";
append fmt " You must define network and block interfaces manually.";
append fmt
" See http://libvirt.org/drvxen.html for information about \
converting .xl-files to libvirt xml automatically.";
append fmt " -->";
append fmt " <devices>";
append fmt " <!--";
append fmt " The disk configuration is defined here:";
append fmt " http://libvirt.org/formatstorage.html.";
append fmt " An example would look like:";
append fmt " <disk type='block' device='disk'>";
append fmt " <driver name='phy'/>";
append fmt " <source dev='/dev/loop0'/>";
append fmt " <target dev='' bus='xen'/>";
append fmt " </disk>";
append fmt " -->";
append fmt " <!-- ";
append fmt " The network configuration is defined here:";
append fmt " http://libvirt.org/formatnetwork.html";
append fmt " An example would look like:";
append fmt " <interface type='bridge'>";
append fmt " <mac address='c0:ff:ee:c0:ff:ee'/>";
append fmt " <source bridge='br0'/>";
append fmt " </interface>";
append fmt " -->";
append fmt " <console type='pty'>";
append fmt " <target type='xen' port='0'/>";
append fmt " </console>";
append fmt " </devices>";
append fmt "</domain>")
let configure_virtio ~name =
Action.with_output ~path:(filename ~name) ~purpose:"libvirt.xml" (fun fmt ->
append fmt "<domain type='kvm'>";
append fmt " <name>%s</name>" name;
append fmt " <memory unit='KiB'>262144</memory>";
append fmt " <currentMemory unit='KiB'>262144</currentMemory>";
append fmt " <vcpu placement='static'>1</vcpu>";
append fmt " <os>";
append fmt " <type arch='x86_64' machine='pc'>hvm</type>";
append fmt " <kernel>%s.virtio</kernel>" name;
append fmt " <!-- Command line arguments can be given if required:";
append fmt " <cmdline>-l *:debug</cmdline>";
append fmt " -->";
append fmt " </os>";
append fmt " <clock offset='utc' adjustment='reset'/>";
append fmt " <devices>";
append fmt " <emulator>/usr/bin/qemu-system-x86_64</emulator>";
append fmt " <!--";
append fmt " Disk/block configuration reference is here:";
append fmt " https://libvirt.org/formatdomain.html#elementsDisks";
append fmt
" This example uses a raw file on the host as a block in the \
guest:";
append fmt " <disk type='file' device='disk'>";
append fmt " <driver name='qemu' type='raw'/>";
append fmt " <source file='/var/lib/libvirt/images/%s.img'/>"
name;
append fmt " <target dev='vda' bus='virtio'/>";
append fmt " </disk>";
append fmt " -->";
append fmt " <!-- ";
append fmt " Network configuration reference is here:";
append fmt " https://libvirt.org/formatdomain.html#elementsNICS";
append fmt
" This example adds a device in the 'default' libvirt bridge:";
append fmt " <interface type='bridge'>";
append fmt " <source bridge='virbr0'/>";
append fmt " <model type='virtio'/>";
append fmt " <alias name='0'/>";
append fmt " </interface>";
append fmt " -->";
append fmt " <serial type='pty'>";
append fmt " <target port='0'/>";
append fmt " </serial>";
append fmt " <console type='pty'>";
append fmt " <target type='serial' port='0'/>";
append fmt " </console>";
append fmt " <memballoon model='none'/>";
append fmt " </devices>";
append fmt "</domain>")

3
unikernel/duniverse/mirage/lib/devices/libvirt.mli Normal file
View file

@ -0,0 +1,3 @@
val filename : name:string -> Fpath.t
val configure_main : name:string -> unit Functoria.Action.t
val configure_virtio : name:string -> unit Functoria.Action.t

18
unikernel/duniverse/mirage/lib/devices/mimic.ml Normal file
View file

@ -0,0 +1,18 @@
open Functoria.DSL
type mimic = Mimic
let mimic = typ Mimic
let mimic_happy_eyeballs =
let packages = [ package "mimic-happy-eyeballs" ~min:"0.0.9" ] in
let connect _ modname = function
| [ _stackv4v6; happy_eyeballs; _dns_client ] ->
code ~pos:__POS__ {ocaml|%s.connect %s|ocaml} modname happy_eyeballs
| _ -> Misc.connect_err "mimic" 3
in
impl ~packages ~connect "Mimic_happy_eyeballs.Make"
(Stack.stackv4v6
@-> Happy_eyeballs.happy_eyeballs
@-> Dns.dns_client
@-> mimic)

16
unikernel/duniverse/mirage/lib/devices/misc.ml Normal file
View file

@ -0,0 +1,16 @@
let get_target i = Key.(get (Functoria.Info.context i) target)
let connect_err name number =
let str =
Fmt.str "The %s connect expects exactly %d argument%s" name number
(if number = 1 then "" else "s")
in
failwith str
let terminal () =
let dumb = try Sys.getenv "TERM" = "dumb" with Not_found -> true in
let isatty =
try Unix.(isatty (descr_of_out_channel Stdlib.stdout))
with Unix.Unix_error _ -> false
in
(not dumb) && isatty

3
unikernel/duniverse/mirage/lib/devices/misc.mli Normal file
View file

@ -0,0 +1,3 @@
val get_target : Functoria.Info.t -> Key.mode
val connect_err : string -> int -> 'a
val terminal : unit -> bool

18
unikernel/duniverse/mirage/lib/devices/mtime.ml Normal file
View file

@ -0,0 +1,18 @@
open Functoria.DSL
type mtime = job
let mtime = Functoria.job
let no_mtime = impl "Mirage_runtime" mtime
let impl sublib =
let packages =
[ package ~min:"5.2.0" ~max:"6.0.0" ~sublibs:[ ""; sublib ] "mirage-mtime" ]
in
impl ~packages "Mirage_mtime" mtime
let default_mtime =
if_impl Key.is_unix (impl "unix")
(if_impl Key.is_unikraft (impl "unikraft") (impl "solo5"))
let mock_mtime = impl "mock"

8
unikernel/duniverse/mirage/lib/devices/mtime.mli Normal file
View file

@ -0,0 +1,8 @@
open Functoria.DSL
type mtime = job
val mtime : mtime typ
val default_mtime : mtime impl
val no_mtime : mtime impl
val mock_mtime : mtime impl

53
unikernel/duniverse/mirage/lib/devices/network.ml Normal file
View file

@ -0,0 +1,53 @@
open Functoria.DSL
open Functoria.Action
type network = NETWORK
let network = typ NETWORK
let all_networks = ref []
let add_new_network name = all_networks := name :: !all_networks
let network_conf ?(intf : string runtime_arg option) name =
let runtime_args = Option.to_list (Option.map Runtime_arg.v intf) in
let packages_v =
Key.match_ Key.(value target) @@ function
| `Unix -> [ package ~min:"3.0.0" ~max:"4.0.0" "mirage-net-unix" ]
| `MacOSX -> [ package ~min:"1.8.0" ~max:"2.0.0" "mirage-net-macosx" ]
| `Xen -> [ package ~min:"2.1.0" ~max:"3.0.0" "mirage-net-xen" ]
| `Qubes ->
[ package ~min:"2.1.0" ~max:"3.0.0" "mirage-net-xen"; Qubesdb.pkg ]
| #Key.mode_solo5 ->
[ package ~min:"0.8.0" ~max:"0.9.0" "mirage-net-solo5" ]
| #Key.mode_unikraft ->
[ package ~min:"1.0.0" ~max:"2.0.0" "mirage-net-unikraft" ]
in
let connect _ modname = function
| [] -> code ~pos:__POS__ "%s.connect %S" modname name
| [ intf ] -> code ~pos:__POS__ "%s.connect %s" modname intf
| _ -> Misc.connect_err "network_conf (sometimes 0 arguments)" 1
in
let configure _ =
add_new_network name;
ok ()
in
impl ~runtime_args ~packages_v ~connect ~configure "Netif" network
let netif ?group dev =
if_impl Key.is_solo5 (network_conf dev)
(network_conf ~intf:(Runtime_arg.interface ?group dev) dev)
let default_network =
match_impl
Key.(value target)
[
(`Unix, netif "tap0");
(`MacOSX, netif "tap0");
(* On Solo5 targets, a single default network is customarily
* named just 'service' *)
(`Hvt, netif "service");
(`Spt, netif "service");
(`Virtio, netif "service");
(`Muen, netif "service");
(`Genode, netif "service");
]
~default:(netif "0")

8
unikernel/duniverse/mirage/lib/devices/network.mli Normal file
View file

@ -0,0 +1,8 @@
open Functoria.DSL
type network
val network : network typ
val netif : ?group:string -> string -> network impl
val default_network : network impl
val all_networks : string list ref

18
unikernel/duniverse/mirage/lib/devices/ptime.ml Normal file
View file

@ -0,0 +1,18 @@
open Functoria.DSL
type ptime = job
let ptime = Functoria.job
let no_ptime = impl "Mirage_runtime" ptime
let impl sublib =
let packages =
[ package ~min:"5.1.0" ~max:"6.0.0" ~sublibs:[ ""; sublib ] "mirage-ptime" ]
in
impl ~packages "Mirage_ptime" ptime
let default_ptime =
if_impl Key.is_unix (impl "unix")
(if_impl Key.is_unikraft (impl "unikraft") (impl "solo5"))
let mock_ptime = impl "mock"

8
unikernel/duniverse/mirage/lib/devices/ptime.mli Normal file
View file

@ -0,0 +1,8 @@
open Functoria.DSL
type ptime = job
val ptime : ptime typ
val default_ptime : ptime impl
val no_ptime : ptime impl
val mock_ptime : ptime impl

22
unikernel/duniverse/mirage/lib/devices/qubesdb.ml Normal file
View file

@ -0,0 +1,22 @@
open Functoria.DSL
open Functoria.Action
type qubesdb = QUBES_DB
let qubesdb = typ QUBES_DB
let pkg = package ~min:"2.0.0" ~max:"3.0.0" "mirage-qubes"
let default_qubesdb =
let packages = [ pkg ] in
let configure i =
match Misc.get_target i with
| `Qubes | `Xen -> ok ()
| _ ->
error
"Qubes DB invoked for an unsupported target; qubes and xen are \
supported"
in
let connect _ modname _args =
code ~pos:__POS__ "%s.connect ~domid:0 ()" modname
in
impl ~packages ~configure ~connect "Qubes.DB" qubesdb

7
unikernel/duniverse/mirage/lib/devices/qubesdb.mli Normal file
View file

@ -0,0 +1,7 @@
open Functoria.DSL
type qubesdb
val qubesdb : qubesdb typ
val default_qubesdb : qubesdb impl
val pkg : package

17
unikernel/duniverse/mirage/lib/devices/random.ml Normal file
View file

@ -0,0 +1,17 @@
open Functoria.DSL
type random = job
let random = Functoria.job
let default_random =
let packages =
[ package ~min:"2.0.0" ~max:"3.0.0" "mirage-crypto-rng-mirage" ]
in
let connect _ modname _ =
(* here we could use the boot argument (--prng) to select the RNG! *)
code ~pos:__POS__ "%s.initialize (module Mirage_crypto_rng.Fortuna)" modname
in
impl ~packages ~connect "Mirage_crypto_rng_mirage" random
let no_random = impl "Mirage_runtime" random

7
unikernel/duniverse/mirage/lib/devices/random.mli Normal file
View file

@ -0,0 +1,7 @@
open Functoria.DSL
type random = job
val random : random typ
val no_random : random impl
val default_random : random impl

30
unikernel/duniverse/mirage/lib/devices/reporter.ml Normal file
View file

@ -0,0 +1,30 @@
open Functoria.DSL
type reporter = job
let reporter = Functoria.job
let pp_level ppf = function
| Some Logs.Error -> Fmt.string ppf "(Some Logs.Error)"
| Some Logs.Warning -> Fmt.string ppf "(Some Logs.Warning)"
| Some Logs.Info -> Fmt.string ppf "(Some Logs.Info)"
| Some Logs.Debug -> Fmt.string ppf "(Some Logs.Debug)"
| Some Logs.App -> Fmt.string ppf "(Some Logs.App)"
| None -> Fmt.string ppf "None"
let default_reporter ?(level = Some Logs.Info) () =
let packages = [ package ~min:"3.0.0" ~max:"4.0.0" "mirage-logs" ] in
let runtime_args = [ Runtime_arg.v Runtime_arg.logs ] in
let connect _ modname = function
| [ logs ] ->
code ~pos:__POS__
"@[<v 2>let reporter = %s.create () in@ Mirage_runtime.set_level \
~default:%a %s;@ Logs.set_reporter reporter;@ Lwt.return reporter@]"
modname pp_level level logs
| _ -> Misc.connect_err "log" 1
in
impl ~packages ~runtime_args ~connect "Mirage_logs" reporter
let no_reporter =
let connect _ _ _ = code ~pos:__POS__ "assert false" in
impl ~connect "Mirage_runtime" reporter

7
unikernel/duniverse/mirage/lib/devices/reporter.mli Normal file
View file

@ -0,0 +1,7 @@
open Functoria.DSL
type reporter = job
val reporter : reporter typ
val default_reporter : ?level:Logs.level option -> unit -> reporter impl
val no_reporter : reporter impl

42
unikernel/duniverse/mirage/lib/devices/resolver.ml Normal file
View file

@ -0,0 +1,42 @@
open Functoria.DSL
open Functoria.Action
type resolver = Resolver
let resolver = typ Resolver
let resolver_unix_system =
let packages_v =
Key.(if_ is_unix)
[ Conduit.pkg; package ~min:"8.0.0" ~max:"9.0.0" "conduit-lwt-unix" ]
[]
in
let configure i =
match Misc.get_target i with
| `Unix | `MacOSX -> ok ()
| _ -> error "Unix resolver not supported on non-UNIX targets."
in
let connect _ _modname _ =
code ~pos:__POS__ "Lwt.return Resolver_lwt_unix.system"
in
impl ~packages_v ~configure ~connect "Resolver_lwt" resolver
let resolver_dns_conf ~ns =
let packages = [ Conduit.pkg ] in
let runtime_args = Runtime_arg.[ v ns ] in
let connect _ modname = function
| [ stack; ns ] ->
code ~pos:__POS__
"let nameservers = %s in@;\
%s.v ?nameservers %s >|= function@;\
| Ok r -> r@;\
| Error (`Msg e) -> invalid_arg e@;"
ns modname stack
| _ -> Misc.connect_err "resolver" 2
in
impl ~packages ~runtime_args ~connect "Resolver_mirage.Make"
(Stack.stackv4v6 @-> resolver)
let resolver_dns ?ns stack =
let ns = Runtime_arg.resolver ?default:ns () in
resolver_dns_conf ~ns $ stack

7
unikernel/duniverse/mirage/lib/devices/resolver.mli Normal file
View file

@ -0,0 +1,7 @@
open Functoria.DSL
type resolver
val resolver : resolver typ
val resolver_dns : ?ns:string list -> Stack.stackv4v6 impl -> resolver impl
val resolver_unix_system : resolver impl

199
unikernel/duniverse/mirage/lib/devices/runtime_arg.ml Normal file
View file

@ -0,0 +1,199 @@
(*
* Copyright (c) 2023 Thomas Gazagnaire <thomas@gazagnaire.org>
*
* 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 Functoria.DSL
include Functoria.Runtime_arg
(** {2 OCaml runtime} *)
let runtime_arg ~pos name =
create ~pos
~packages:[ package "mirage-runtime" ]
(Fmt.str "Mirage_runtime.%s" name)
let runtime_network_key ~pos fmt =
Fmt.kstr
(create ~pos ~packages:[ package "mirage-runtime" ~sublibs:[ "network" ] ])
("Mirage_runtime_network." ^^ fmt)
let delay = runtime_arg ~pos:__POS__ "delay"
let pp_group ppf = function
| None | Some "" -> ()
| Some g -> Fmt.pf ppf "~group:%S " g
let pp_docs ppf = function
| None | Some "" -> ()
| Some g -> Fmt.pf ppf "~docs:%S " g
let pp_option pp ppf = function
| None -> Fmt.pf ppf "None"
| Some d -> Fmt.pf ppf "(Some %a)" pp d
let escape pp ppf = Fmt.kstr (fun str -> Fmt.Dump.string ppf str) "%a" pp
(** {3 Network keys} *)
let interface ?group ?docs default =
runtime_network_key ~pos:__POS__ "interface %a%a%S" pp_group group pp_docs
docs default
module V4 = struct
open Ipaddr.V4
let pp_prefix ppf p =
Fmt.pf ppf "(Ipaddr.V4.Prefix.of_string_exn %a)" (escape Prefix.pp) p
let pp ppf p = Fmt.pf ppf "(Ipaddr.V4.of_string_exn %a)" (escape pp) p
let network ?group ?docs default =
runtime_network_key ~pos:__POS__ "V4.network %a%a%a" pp_group group pp_docs
docs pp_prefix default
let gateway ?group ?docs default =
runtime_network_key ~pos:__POS__ "V4.gateway %a%a%a" pp_group group pp_docs
docs (pp_option pp) default
end
module V6 = struct
open Ipaddr.V6
let pp_prefix ppf p =
Fmt.pf ppf "(Ipaddr.V6.Prefix.of_string_exn %a)" (escape Prefix.pp) p
let pp ppf p = Fmt.pf ppf "(Ipaddr.V6.of_string_exn %a)" (escape pp) p
let network ?group ?docs default =
runtime_network_key ~pos:__POS__ "V6.network %a%a%a" pp_group group pp_docs
docs (pp_option pp_prefix) default
let gateway ?group ?docs default =
runtime_network_key ~pos:__POS__ "V6.gateway %a%a%a" pp_group group pp_docs
docs (pp_option pp) default
let accept_router_advertisements ?group ?docs () =
runtime_network_key ~pos:__POS__ "V6.accept_router_advertisements %a%a()"
pp_group group pp_docs docs
end
let ipv4_only ?group ?docs () =
runtime_network_key ~pos:__POS__ "ipv4_only %a%a()" pp_group group pp_docs
docs
let ipv6_only ?group ?docs () =
runtime_network_key ~pos:__POS__ "ipv6_only %a%a()" pp_group group pp_docs
docs
let resolver ?group ?docs ?(default = []) () =
let pp_default ppf = function
| [] -> ()
| l -> Fmt.pf ppf "~default:%a " Fmt.Dump.(list string) l
in
runtime_network_key ~pos:__POS__ "resolver %a%a%a()" pp_group group pp_docs
docs pp_default default
let dns_servers ?group ?docs default =
runtime_network_key ~pos:__POS__ "dns_servers %a%a%a" pp_group group pp_docs
docs
(pp_option Fmt.Dump.(list string))
default
let dns_timeout ?group ?docs default =
runtime_network_key ~pos:__POS__ "dns_timeout %a%a%a" pp_group group pp_docs
docs (pp_option Fmt.int64) default
let dns_cache_size ?group ?docs default =
runtime_network_key ~pos:__POS__ "dns_cache_size %a%a%a" pp_group group
pp_docs docs (pp_option Fmt.int) default
let he_aaaa_timeout ?group ?docs default =
runtime_network_key ~pos:__POS__ "he_aaaa_timeout %a%a%a" pp_group group
pp_docs docs (pp_option Fmt.int64) default
let he_connect_delay ?group ?docs default =
runtime_network_key ~pos:__POS__ "he_connect_delay %a%a%a" pp_group group
pp_docs docs (pp_option Fmt.int64) default
let he_connect_timeout ?group ?docs default =
runtime_network_key ~pos:__POS__ "he_connect_timeout %a%a%a" pp_group group
pp_docs docs (pp_option Fmt.int64) default
let he_resolve_timeout ?group ?docs default =
runtime_network_key ~pos:__POS__ "he_resolve_timeout %a%a%a" pp_group group
pp_docs docs (pp_option Fmt.int64) default
let he_resolve_retries ?group ?docs default =
runtime_network_key ~pos:__POS__ "he_resolve_retries %a%a%a" pp_group group
pp_docs docs (pp_option Fmt.int) default
let he_timer_interval ?group ?docs default =
runtime_network_key ~pos:__POS__ "he_timer_interval %a%a%a" pp_group group
pp_docs docs (pp_option Fmt.int64) default
let ssh_key ?group ?docs default =
runtime_network_key ~pos:__POS__ "ssh_key %a%a%a" pp_group group pp_docs docs
(pp_option Fmt.Dump.string)
default
let ssh_password ?group ?docs default =
runtime_network_key ~pos:__POS__ "ssh_password %a%a%a" pp_group group pp_docs
docs
(pp_option Fmt.Dump.string)
default
let ssh_authenticator ?group ?docs default =
runtime_network_key ~pos:__POS__ "ssh_authenticator %a%a%a" pp_group group
pp_docs docs
(pp_option Fmt.Dump.string)
default
let tls_authenticator ?group ?docs default =
runtime_network_key ~pos:__POS__ "tls_authenticator %a%a%a" pp_group group
pp_docs docs
(pp_option Fmt.Dump.string)
default
let http_headers ?group ?docs default =
runtime_network_key ~pos:__POS__ "http_headers %a%a%a" pp_group group pp_docs
docs
(pp_option Fmt.Dump.(list (pair string string)))
default
let pp_ipaddr ppf p = Fmt.pf ppf "Ipaddr.of_string %a" (escape Ipaddr.pp) p
let syslog ?group ?docs default =
runtime_network_key ~pos:__POS__ "syslog %a%a%a" pp_group group pp_docs docs
(pp_option pp_ipaddr) default
let syslog_port ?group ?docs default =
runtime_network_key ~pos:__POS__ "syslog_port %a%a%a" pp_group group pp_docs
docs (pp_option Fmt.int) default
let syslog_truncate ?group ?docs default =
runtime_network_key ~pos:__POS__ "syslog_truncate %a%a%a" pp_group group
pp_docs docs (pp_option Fmt.int) default
let syslog_keyname ?group ?docs default =
runtime_network_key ~pos:__POS__ "syslog_keyname %a%a%a" pp_group group
pp_docs docs (pp_option Fmt.string) default
let monitor ?group ?docs default =
runtime_network_key ~pos:__POS__ "monitor %a%a%a" pp_group group pp_docs docs
(pp_option pp_ipaddr) default
type log_threshold = [ `All | `Src of string ] * Logs.level option
let logs = runtime_arg ~pos:__POS__ "logs"

183
unikernel/duniverse/mirage/lib/devices/runtime_arg.mli Normal file
View file

@ -0,0 +1,183 @@
(*
* Copyright (c) 2023 Thomas Gazagnaire <thomas@gazagnaire.org>
*
* 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.
*)
(** Command-line arguments for Mirage applications. *)
open Functoria.DSL
include module type of Functoria.Runtime_arg
type 'a arg = 'a runtime_arg
(** The type for command-line arguments that reads a value of type ['a]. *)
val create :
pos:string * int * int * int -> ?packages:package list -> string -> 'a arg
val v : 'a arg -> Functoria.Runtime_arg.t
(** [v k] is the [k] with its type hidden. *)
(** {3 Network Arguments} *)
val interface : ?group:string -> ?docs:string -> string -> string runtime_arg
(** A network interface. *)
(** Ipv4 Arguments. *)
module V4 : sig
open Ipaddr.V4
val network :
?group:string -> ?docs:string -> Prefix.t -> Prefix.t runtime_arg
(** A network defined by an address and netmask. *)
val gateway :
?group:string -> ?docs:string -> t option -> t option runtime_arg
(** A default gateway option. *)
end
(** Ipv6 Arguments. *)
module V6 : sig
open Ipaddr.V6
val network :
?group:string ->
?docs:string ->
Prefix.t option ->
Prefix.t option runtime_arg
(** A network defined by an address and netmask. *)
val gateway :
?group:string -> ?docs:string -> t option -> t option runtime_arg
(** A default gateway option. *)
val accept_router_advertisements :
?group:string -> ?docs:string -> unit -> bool runtime_arg
(** An option whether to accept router advertisements. *)
end
val ipv4_only : ?group:string -> ?docs:string -> unit -> bool runtime_arg
(** An option for dual stack to only use IPv4. *)
val ipv6_only : ?group:string -> ?docs:string -> unit -> bool runtime_arg
(** An option for dual stack to only use IPv6. *)
val resolver :
?group:string ->
?docs:string ->
?default:string list ->
unit ->
string list option runtime_arg
(** The address of the DNS resolver to use. See $REFERENCE for format. *)
val dns_servers :
?group:string ->
?docs:string ->
string list option ->
string list option runtime_arg
(** The addresses of the DNS servers to use. *)
val dns_timeout :
?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
(** The timeout (in nanoseconds) for DNS resolution. *)
val dns_cache_size :
?group:string -> ?docs:string -> int option -> int option runtime_arg
(** The cache size of the LRU cache used for DNS resolution. *)
val he_aaaa_timeout :
?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
(** The timeout (in nanoseconds) for IPv6 resolution. *)
val he_connect_delay :
?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
(** The delay (in nanoseconds) for establishing connections. *)
val he_connect_timeout :
?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
(** The timeout (in nanoseconds) for establishing connections. *)
val he_resolve_timeout :
?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
(** The timeout (in nanoseconds) for resolving hostnames. *)
val he_resolve_retries :
?group:string -> ?docs:string -> int option -> int option runtime_arg
(** The number of resolution attempts before an error is returned. *)
val he_timer_interval :
?group:string -> ?docs:string -> int64 option -> int64 option runtime_arg
(** The interval (in nanoseconds) when the timer is executed. *)
val ssh_key :
?group:string -> ?docs:string -> string option -> string option runtime_arg
(** A SSH private key. *)
val ssh_password :
?group:string -> ?docs:string -> string option -> string option runtime_arg
(** A SSH password. *)
val ssh_authenticator :
?group:string -> ?docs:string -> string option -> string option runtime_arg
(** A SSH authenticator. *)
val tls_authenticator :
?group:string -> ?docs:string -> string option -> string option runtime_arg
(** A TLS authenticator. *)
val http_headers :
?group:string ->
?docs:string ->
(string * string) list option ->
(string * string) list option runtime_arg
(** HTTP headers. *)
val syslog :
?group:string ->
?docs:string ->
Ipaddr.t option ->
Ipaddr.t option runtime_arg
(** The address to send syslog frames to. *)
val syslog_port : ?group:string -> ?docs:string -> int option -> int runtime_arg
(** The port to send syslog frames to. *)
val syslog_truncate :
?group:string -> ?docs:string -> int option -> int option runtime_arg
(** Truncate syslog frames to a specific byte count, [docs] defaults to
{!Mirage_runtime.s_log}. *)
val syslog_keyname :
?group:string -> ?docs:string -> string option -> string option runtime_arg
(** TLS key used for syslog, [docs] defaults to {!Mirage_runtime.s_log}. *)
val monitor :
?group:string ->
?docs:string ->
Ipaddr.t option ->
Ipaddr.t option runtime_arg
(** The address to send monitor statistics to. *)
(** {3 Logs} *)
type log_threshold = [ `All | `Src of string ] * Logs.level option
(** The type for log threshold. A log level of [None] disables logging. *)
val logs : log_threshold list runtime_arg
(** {3 Startup delay} *)
val delay : int runtime_arg
(** The initial delay, specified in seconds, before a unikernel starting up.
Defaults to 0. Useful for tenders and environments that take some time to
bring devices up. *)

16
unikernel/duniverse/mirage/lib/devices/sleep.ml Normal file
View file

@ -0,0 +1,16 @@
open Functoria.DSL
type sleep = job
let sleep = Functoria.job
let no_sleep = impl "Mirage_runtime" sleep
let impl sublib =
let packages =
[ package ~min:"4.1.0" ~max:"5.0.0" ~sublibs:[ ""; sublib ] "mirage-sleep" ]
in
impl ~packages "Mirage_sleep" sleep
let default_sleep =
if_impl Key.is_unix (impl "unix")
(if_impl Key.is_unikraft (impl "unikraft") (impl "solo5"))

7
unikernel/duniverse/mirage/lib/devices/sleep.mli Normal file
View file

@ -0,0 +1,7 @@
open Functoria.DSL
type sleep = job
val sleep : sleep typ
val default_sleep : sleep impl
val no_sleep : sleep impl

112
unikernel/duniverse/mirage/lib/devices/stack.ml Normal file
View file

@ -0,0 +1,112 @@
open Functoria.DSL
let dhcp_ipv4 tap e a = Ip.ipv4_of_dhcp tap e a
let qubes_ipv4 ?(qubesdb = Qubesdb.default_qubesdb) e a =
Ip.ipv4_qubes qubesdb e a
(** dual stack *)
type stackv4v6 = STACKV4V6
let stackv4v6 = typ STACKV4V6
let stackv4v6_direct_conf () =
let packages_v = Ip.right_tcpip_library ~sublibs:[ "stack-direct" ] "tcpip" in
let connect _i modname = function
| [ interface; ethif; arp; ipv4v6; icmpv4; udp; tcp ] ->
code ~pos:__POS__ "%s.connect %s %s %s %s %s %s %s" modname interface
ethif arp ipv4v6 icmpv4 udp tcp
| _ -> Misc.connect_err "direct stack" 7
in
impl ~packages_v ~connect "Tcpip_stack_direct.MakeV4V6"
(Network.network
@-> Ethernet.ethernet
@-> Arp.arpv4
@-> Ip.ipv4v6
@-> Icmp.icmpv4
@-> Udp.udp
@-> Tcp.tcp
@-> stackv4v6)
let direct_stackv4v6 ?group ?tcp network eth arp ipv4 ipv6 =
let ipv4_only = Runtime_arg.ipv4_only ?group ()
and ipv6_only = Runtime_arg.ipv6_only ?group () in
let ip = Ip.keyed_ipv4v6 ~ipv4_only ~ipv6_only ipv4 ipv6 in
stackv4v6_direct_conf ()
$ network
$ eth
$ arp
$ ip
$ Icmp.direct_icmpv4 ipv4
$ Udp.direct_udp ip
$ match tcp with None -> Tcp.direct_tcp ip | Some tcp -> tcp
let keyed_direct_stackv4v6 ?tcp ~ipv4_only ~ipv6_only network eth arp ipv4 ipv6
=
let ip = Ip.keyed_ipv4v6 ~ipv4_only ~ipv6_only ipv4 ipv6 in
stackv4v6_direct_conf ()
$ network
$ eth
$ arp
$ ip
$ Icmp.direct_icmpv4 ipv4
$ Udp.direct_udp ip
$ match tcp with None -> Tcp.direct_tcp ip | Some tcp -> tcp
let generic_ipv4v6_stack p ?group ?ipv4_network ?ipv4_gateway ?ipv6_network
?ipv6_gateway ?(arp = Arp.arp) ?tcp tap =
let ipv4_only = Runtime_arg.ipv4_only ?group ()
and ipv6_only = Runtime_arg.ipv6_only ?group () in
let e = Ethernet.ethif tap in
let a = arp e in
let i4 =
match_impl p
[ (`Qubes, qubes_ipv4 e a); (`Dhcp, dhcp_ipv4 tap e a) ]
~default:
(Ip.keyed_create_ipv4 ?group ?network:ipv4_network ?gateway:ipv4_gateway
~no_init:ipv6_only e a)
in
let i6 =
Ip.keyed_create_ipv6 ?group ?network:ipv6_network ?gateway:ipv6_gateway
~no_init:ipv4_only tap e
in
keyed_direct_stackv4v6 ~ipv4_only ~ipv6_only ?tcp tap e a i4 i6
let socket_stackv4v6 ?(group = "") () =
let v4key = Runtime_arg.V4.network ~group Ipaddr.V4.Prefix.global in
let v6key = Runtime_arg.V6.network ~group None in
let ipv4_only = Runtime_arg.ipv4_only ~group () in
let ipv6_only = Runtime_arg.ipv6_only ~group () in
let packages_v = Ip.right_tcpip_library ~sublibs:[ "stack-socket" ] "tcpip" in
let extra_deps =
[
dep (Udp.udpv4v6_socket_conf ~ipv4_only ~ipv6_only v4key v6key);
dep (Tcp.tcpv4v6_socket_conf ~ipv4_only ~ipv6_only v4key v6key);
]
in
let connect _i modname = function
| [ udp; tcp ] -> code ~pos:__POS__ "%s.connect %s %s" modname udp tcp
| _ -> Misc.connect_err "socket_stackv4v6" 2
in
impl ~packages_v ~extra_deps ~connect "Tcpip_stack_socket.V4V6" stackv4v6
(** Generic stack *)
let generic_stackv4v6 ?group ?(dhcp_key = Key.value @@ Key.dhcp ?group ())
?(net_key = Key.value @@ Key.net ?group ()) ?ipv4_network ?ipv4_gateway
?ipv6_network ?ipv6_gateway ?tcp (tap : Network.network impl) :
stackv4v6 impl =
let choose target net dhcp =
match (target, net, dhcp) with
| `Qubes, _, _ -> `Qubes
| _, Some `Host, _ -> `Socket
| _, _, true -> `Dhcp
| (`Unix | `MacOSX), None, false -> `Socket
| _, _, _ -> `Static
in
let p = Key.(pure choose $ Key.(value target) $ net_key $ dhcp_key) in
match_impl p
[ (`Socket, socket_stackv4v6 ?group ()) ]
~default:
(generic_ipv4v6_stack p ?group ?ipv4_network ?ipv4_gateway ?ipv6_network
?ipv6_gateway ?tcp tap)

27
unikernel/duniverse/mirage/lib/devices/stack.mli Normal file
View file

@ -0,0 +1,27 @@
open Functoria.DSL
type stackv4v6
val stackv4v6 : stackv4v6 typ
val direct_stackv4v6 :
?group:string ->
?tcp:Tcp.tcpv4v6 impl ->
Network.network impl ->
Ethernet.ethernet impl ->
Arp.arpv4 impl ->
Ip.ipv4 impl ->
Ip.ipv6 impl ->
stackv4v6 impl
val generic_stackv4v6 :
?group:string ->
?dhcp_key:bool value ->
?net_key:[ `OCaml | `Host ] option value ->
?ipv4_network:Ipaddr.V4.Prefix.t ->
?ipv4_gateway:Ipaddr.V4.t ->
?ipv6_network:Ipaddr.V6.Prefix.t ->
?ipv6_gateway:Ipaddr.V6.t ->
?tcp:Tcp.tcpv4v6 impl ->
Network.network impl ->
stackv4v6 impl

95
unikernel/duniverse/mirage/lib/devices/syslog.ml Normal file
View file

@ -0,0 +1,95 @@
open Functoria.DSL
type syslog = SYSLOG
let syslog = typ SYSLOG
let pkg sublibs = [ package ~min:"0.5.0" ~max:"0.6.0" ~sublibs "logs-syslog" ]
let syslog_udp_conf ?group () =
let endpoint = Runtime_arg.syslog ?group None
and port = Runtime_arg.syslog_port ?group None
and truncate = Runtime_arg.syslog_truncate ?group None in
let packages = pkg [ "mirage" ] in
let runtime_args = Runtime_arg.[ v endpoint; v port; v truncate ] in
let connect _i modname = function
| [ stack; endpoint; port; truncate ] ->
code ~pos:__POS__
"@[<v 2>match %s with@ | None ->Logs.warn (fun m -> m \"no syslog \
server specified, dumping logs to stdout\"); Lwt.return_unit@ | \
Some server ->@ let reporter =@ %s.create %s \
~hostname:(Mirage_runtime.name ()) ~port:%s server ?truncate:%s ()@ \
in@ Logs.set_reporter reporter;@ Lwt.return_unit@]"
endpoint modname stack port truncate
| _ -> Misc.connect_err "syslog_udp" 5
in
impl ~packages ~runtime_args ~connect "Logs_syslog_mirage.Udp"
(Stack.stackv4v6 @-> syslog)
let syslog_udp ?group stack = syslog_udp_conf ?group () $ stack
let syslog_tcp_conf ?group () =
let endpoint = Runtime_arg.syslog ?group None
and port = Runtime_arg.syslog_port ?group None
and truncate = Runtime_arg.syslog_truncate ?group None in
let packages = pkg [ "mirage" ] in
let runtime_args = Runtime_arg.[ v endpoint; v port; v truncate ] in
let connect _i modname = function
| [ stack; endpoint; port; truncate ] ->
code ~pos:__POS__
"@[<v 2>match %s with@ | None -> Logs.warn (fun m -> m \"no syslog \
server specified, dumping logs to stdout\"); Lwt.return_unit@ | \
Some server ->@ %s.create %s ~hostname:(Mirage_runtime.name ()) \
~port:%s server ?truncate:%s () >>= function@ | Ok reporter -> \
Logs.set_reporter reporter; Lwt.return_unit@ | Error e -> \
invalid_arg e@]"
endpoint modname stack port truncate
| _ -> Misc.connect_err "syslog_tcp" 5
in
impl ~packages ~runtime_args ~connect "Logs_syslog_mirage.Tcp"
(Stack.stackv4v6 @-> syslog)
let syslog_tcp ?group stack = syslog_tcp_conf ?group () $ stack
let syslog_tls_conf ?group () =
let endpoint = Runtime_arg.syslog ?group None
and port = Runtime_arg.syslog_port ?group None
and truncate = Runtime_arg.syslog_truncate ?group None
and keyname = Runtime_arg.syslog_keyname ?group None in
let packages = pkg [ "mirage"; "mirage.tls" ] in
let runtime_args =
Runtime_arg.[ v endpoint; v port; v truncate; v keyname ]
in
let connect _i modname = function
| [ stack; kv; endpoint; port; truncate; keyname ] ->
code ~pos:__POS__
"@[<v 2>match %s with@ | None -> Logs.warn (fun m -> m \"no syslog \
server specified, dumping logs to stdout\"); Lwt.return_unit@ | \
Some server ->@ %s.create %s %s ~hostname:(Mirage_runtime.name ()) \
~port:%s server ?truncate:%s ?keyname:%s () >>= function@ | Ok \
reporter -> Logs.set_reporter reporter; Lwt.return_unit@ | Error e \
-> invalid_arg e@]"
endpoint modname stack kv port truncate keyname
| _ -> Misc.connect_err "syslog_tls" 8
in
impl ~packages ~runtime_args ~connect "Logs_syslog_mirage_tls.Tls"
(Stack.stackv4v6 @-> Kv.ro @-> syslog)
let syslog_tls ?group stack kv = syslog_tls_conf ?group () $ stack $ kv
let monitoring_conf ?group () =
let monitor_host = Runtime_arg.monitor ?group None in
let packages = [ package ~min:"0.0.6" ~max:"0.1.0" "mirage-monitoring" ] in
let runtime_args = Runtime_arg.[ v monitor_host ] in
let connect _i modname = function
| [ stack; monitor ] ->
code ~pos:__POS__
"Lwt.return (match %s with| None -> Logs.warn (fun m -> m \"no \
monitor specified, not outputting statistics\")| Some ip -> \
%s.create ip ~hostname:(Mirage_runtime.name ()) %s)"
monitor modname stack
| _ -> assert false
in
impl ~packages ~runtime_args ~connect "Mirage_monitoring.Make"
(Stack.stackv4v6 @-> Functoria.job)
let monitoring ?group stack = monitoring_conf ?group () $ stack

12
unikernel/duniverse/mirage/lib/devices/syslog.mli Normal file
View file

@ -0,0 +1,12 @@
open Functoria.DSL
type syslog
val syslog : syslog typ
val syslog_udp : ?group:string -> Stack.stackv4v6 impl -> syslog impl
val syslog_tcp : ?group:string -> Stack.stackv4v6 impl -> syslog impl
val syslog_tls :
?group:string -> Stack.stackv4v6 impl -> Kv.ro impl -> syslog impl
val monitoring : ?group:string -> Stack.stackv4v6 impl -> Functoria.job impl

565
unikernel/duniverse/mirage/lib/devices/target.ml Normal file
View file

@ -0,0 +1,565 @@
module Dune = Functoria.Dune
module Info = Functoria.Info
module Install = Functoria.Install
module Action = Functoria.Action
open Functoria.DSL
(** A Mirage target: target consists in multiple backends grouped together. *)
module type TARGET = sig
type t
(** The type representing a specific backend in a target. *)
val cast : Key.mode -> t
(** Ensures the mode is a backend supported by this target. *)
val dune : Info.t -> Dune.stanza list
(** Dune rules to build the unikernel *)
val out : Info.t -> string
(** Name of the output file (with extension) for this target *)
val configure : Info.t -> unit Action.t
(** Configure-time actions. *)
val build_context : ?build_dir:Fpath.t -> Info.t -> Dune.stanza list
(** Generate build context configuration *)
val context_name : Info.t -> string
(** Dune context *)
val packages : t -> package list
(** The required packages to support this backend. *)
val install : Info.t -> Install.t
(** [install i] returns which files are installed in context [i]. *)
end
module Unix = struct
type t = [ `Unix | `MacOSX ]
let cast = function #t as t -> t | _ -> invalid_arg "not a unix target."
let packages _ = [ Functoria.package ~min:"5.0.0" ~max:"6.0.0" "mirage-unix" ]
(*Mirage unix is built on the host build context.*)
let build_context ?build_dir:_ _ = []
let context_name _ = "default"
let configure _ = Action.ok ()
let main i = Fpath.(base (rem_ext (Info.main i)))
let public_name i =
match Info.output i with None -> Info.name i | Some o -> o
let flags =
(* Disable "70 [missing-mli] Missing interface file." as we are only
generating .ml files currently. *)
[ ":standard"; "-w"; "-70" ]
@ if Misc.terminal () then [ "-color"; "always" ] else []
let out = public_name
let dune i =
let libraries = Info.libraries i in
let public_name = public_name i in
let main = Fpath.to_string (main i) in
let pp_list f = Dune.compact_list f in
let dune =
Dune.stanzaf
{|
(rule
(target %s)
(enabled_if (= %%{context_name} "default"))
(deps %s.exe)
(action
(copy %s.exe %%{target})))
(executable
(name %s)
(libraries %a)
(link_flags (-thread))
(modules (:standard \ %a))
(flags %a)
(enabled_if (= %%{context_name} "default"))
)
|}
public_name main main main (pp_list "libraries") libraries Fpath.pp
(Fpath.rem_ext (Fpath.base (Info.config_file i)))
(pp_list "flags") flags
in
[ dune ]
let install i =
let public_name = public_name i in
Install.v ~bin:[ Fpath.(v public_name, v public_name) ] ()
end
module Xen = struct
(* We generate an example .xl with common defaults, and a generic
.xl.in which has @VARIABLES@ which must be substituted by sed
according to the preferences of the system administrator.
The common defaults chosen for the .xl file will be based on values
detected from the build host. We assume that the .xl file will
mainly be used by developers where build and deployment are on the
same host. Production users should use the .xl.in and perform the
appropriate variable substition.
*)
let detected_bridge_name =
(* Best-effort guess of a bridge name stem to use. Note this
inspects the build host and will probably be wrong if the
deployment host is different. *)
match
List.fold_left
(fun sofar x ->
match sofar with
(* This is Linux-specific *)
| None when Sys.file_exists (Fmt.str "/sys/class/net/%s0" x) -> Some x
| None -> None
| Some x -> Some x)
None [ "xenbr"; "br"; "virbr" ]
with
| Some x -> x
| None -> "br"
module Substitutions = struct
type v =
| Name
| Kernel
| Memory
| Block of Block.block_t
| Network of string
type t = (v * string) list
let string_of_v = function
| Name -> "@NAME@"
| Kernel -> "@KERNEL@"
| Memory -> "@MEMORY@"
| Block b -> Fmt.str "@BLOCK:%s@" b.filename
| Network n -> Fmt.str "@NETWORK:%s@" n
let lookup ts v =
if List.mem_assoc v ts then List.assoc v ts else string_of_v v
let defaults i =
let blocks =
List.map
(fun b -> (Block b, b.filename))
(Hashtbl.fold (fun _ v acc -> v :: acc) Block.all_blocks [])
and networks =
List.mapi
(fun i n -> (Network n, Fmt.str "%s%d" detected_bridge_name i))
!Network.all_networks
in
[ (Name, Info.name i); (Kernel, Info.name i ^ ".xen"); (Memory, "256") ]
@ blocks
@ networks
end
let append fmt s = Fmt.pf fmt (s ^^ "@.")
let configure_main_xl ?substitutions ~ext i =
let open Substitutions in
let substitutions =
match substitutions with Some x -> x | None -> defaults i
in
let path = Fpath.(v (Info.name i) + ext) in
Action.with_output ~path ~purpose:"xl file" (fun fmt ->
let open Block in
append fmt "name = '%s'" (lookup substitutions Name);
append fmt "kernel = '%s'" (lookup substitutions Kernel);
append fmt "type = 'pvh'";
append fmt "memory = %s" (lookup substitutions Memory);
append fmt "on_crash = 'preserve'";
append fmt "";
let blocks =
List.map
(fun b ->
(* We need the Linux version of the block number (this is a
strange historical artifact) Taken from
https://github.com/mirage/mirage-block-xen/blob/
a64d152586c7ebc1d23c5adaa4ddd440b45a3a83/lib/device_number.ml#L128 *)
let rec string_of_int26 x =
let high, low = ((x / 26) - 1, (x mod 26) + 1) in
let high' = if high = -1 then "" else string_of_int26 high in
let low' =
String.make 1 (char_of_int (low + int_of_char 'a' - 1))
in
high' ^ low'
in
let vdev = Fmt.str "xvd%s" (string_of_int26 b.number) in
let path = lookup substitutions (Block b) in
Fmt.str "'format=raw, vdev=%s, access=rw, target=%s'" vdev path)
(Hashtbl.fold (fun _ v acc -> v :: acc) all_blocks [])
in
append fmt "disk = [ %s ]" (String.concat ", " blocks);
append fmt "";
let networks =
List.map
(fun n -> Fmt.str "'bridge=%s'" (lookup substitutions (Network n)))
!Network.all_networks
in
append fmt
"# if your system uses openvswitch then either edit /etc/xen/xl.conf \
and set";
append fmt "# vif.default.script=\"vif-openvswitch\"";
append fmt
"# or add \"script=vif-openvswitch,\" before the \"bridge=\" below:";
append fmt "vif = [ %s ]" (String.concat ", " networks))
end
module Solo5 = struct
open Action.Syntax
let solo5_manifest_path = Fpath.v "manifest.json"
type solo5_target = [ `Virtio | `Muen | `Hvt | `Genode | `Spt ]
type xen_target = [ `Xen | `Qubes ]
type t = [ solo5_target | xen_target ]
let cast = function #t as t -> t | _ -> invalid_arg "not a solo5 target."
let build_packages =
[
Functoria.package ~min:"0.8.2" ~max:"2.0.0" ~scope:`Switch ~build:true
"ocaml-solo5";
Functoria.package ~min:"0.7.5" ~max:"0.11.0" ~scope:`Switch ~build:true
"solo5";
]
let runtime_packages target =
match target with
| #solo5_target ->
[ Functoria.package ~min:"0.10.0" ~max:"0.11.0" "mirage-solo5" ]
| #xen_target ->
[ Functoria.package ~min:"9.0.0" ~max:"10.0.0" "mirage-xen" ]
let packages target = build_packages @ runtime_packages target
let context_name _i = "solo5"
(* OCaml solo5 build context. *)
let build_context ?build_dir:_ i =
let build_context =
Dune.stanzaf
{|
(context (default
(name %s)
(host default)
(toolchain solo5)
(merlin)
(disable_dynamically_linked_foreign_archives true)
))
|}
(context_name i)
in
[ build_context ]
(* Configure step *)
let generate_manifest_json with_devices () =
let networks = List.map (fun n -> (n, `Network)) !Network.all_networks in
let blocks =
Hashtbl.fold (fun k _v acc -> (k, `Block) :: acc) Block.all_blocks []
in
let to_string (name, typ) =
Fmt.str {json|{ "name": %S, "type": %S }|json} name
(match typ with `Network -> "NET_BASIC" | `Block -> "BLOCK_BASIC")
in
let devices =
if with_devices then List.map to_string (networks @ blocks) else []
in
let s = String.concat ", " devices in
let* () =
Action.with_output ~path:solo5_manifest_path
~purpose:"Solo5 application manifest file" (fun fmt ->
Fmt.pf fmt
{|{
"type": "solo5.manifest",
"version": 1,
"devices": [ %s ]
}
|}
s)
in
Action.write_file (Fpath.v "manifest.ml") ""
let configure i =
let name = Info.name i in
let target = Info.get i Key.target in
let* () =
match target with
| #solo5_target -> generate_manifest_json true ()
| #xen_target -> generate_manifest_json false ()
| _ -> assert false
in
match target with
| `Xen ->
let* () = Xen.configure_main_xl ~ext:"xl" i in
let* () = Xen.configure_main_xl ~substitutions:[] ~ext:"xl.in" i in
Libvirt.configure_main ~name
| `Virtio -> Libvirt.configure_virtio ~name
| _ -> Action.ok ()
(* Build *)
let ext = function
| `Virtio -> ".virtio"
| `Muen -> ".muen"
| `Hvt -> ".hvt"
| `Genode -> ".genode"
| `Spt -> ".spt"
| `Xen | `Qubes -> ".xen"
| _ -> invalid_arg "solo5 bindings only defined for solo5 targets"
let main i = Fpath.(base (rem_ext (Info.main i)))
let out i =
let target = Info.get i Key.target in
let public_name =
match Info.output i with None -> Info.name i | Some o -> o
in
public_name ^ ext target
let rename i =
let out = out i in
let main = Fpath.to_string (main i) in
Dune.stanzaf
{|
(rule
(target %s)
(enabled_if (= %%{context_name} "%s"))
(deps %s.exe)
(action
(copy %s.exe %%{target})))
|}
out (context_name i) main main
let manifest _i =
Dune.stanzaf
{|
(rule
(targets manifest.c)
(deps manifest.json)
(action
(run solo5-elftool gen-manifest manifest.json manifest.c)))
|}
let solo5_abi = function
| #Key.mode_unix | #Key.mode_unikraft -> assert false
| #Key.mode_xen -> "xen"
| `Virtio -> "virtio"
| `Hvt -> "hvt"
| `Muen -> "muen"
| `Genode -> "genode"
| `Spt -> "spt"
let flags =
(* Disable "70 [missing-mli] Missing interface file." as we are only
generating .ml files currently. *)
[ ":standard"; "-w"; "-70" ]
@ if Misc.terminal () then [ "-color"; "always" ] else []
let main i =
let libraries = Info.libraries i in
let main = Fpath.to_string (main i) in
let target = Info.get i Key.target in
let pp_list f = Dune.compact_list f in
Dune.stanzaf
{|
(executable
(enabled_if (= %%{context_name} "%s"))
(name %s)
(modes (native exe))
(libraries %a)
(link_flags %a -cclib "-z solo5-abi=%s")
(modules (:standard \ %a manifest))
(foreign_stubs (language c) (names manifest))
)
|}
(context_name i) main (pp_list "libraries") libraries
(pp_list "link_flags") flags (solo5_abi target) Fpath.pp
(Fpath.rem_ext (Fpath.base (Info.config_file i)))
let subdir name s = Dune.stanzaf "(subdir %s\n %a)\n" name Dune.pp (Dune.v s)
let dune i = [ main i; manifest i; rename i ]
let install i =
let target = Info.get i Key.target in
let name = Info.name i in
let out = out i in
let open Fpath in
let additional_artifacts =
match target with
| `Xen -> [ v (name ^ ".xl"); v (name ^ ".xl.in") ]
| _ -> []
in
Install.v ~bin:[ (v out, v out) ] ~etc:additional_artifacts ()
end
module Unikraft = struct
type t = [ `Firecracker | `QEMU ]
let configure _ = Action.ok ()
let cast = function #t as t -> t | _ -> invalid_arg "not a Unikraft target."
let build_packages =
[
Functoria.package ~min:"1.0.0" ~max:"2.0.0" ~scope:`Switch ~build:true
"ocaml-unikraft";
Functoria.package ~min:"1.0.0" ~max:"2.0.0" "mirage-unikraft";
]
let backend_packages target =
match target with
| `Firecracker ->
[
Functoria.package ~scope:`Switch ~build:true
"ocaml-unikraft-backend-firecracker";
]
| `QEMU ->
[
Functoria.package ~scope:`Switch ~build:true
"ocaml-unikraft-backend-qemu";
]
let packages target = build_packages @ backend_packages target
let context_name _ = "unikraft"
let unikraft_abi = function
| #Key.mode_unix | #Key.mode_solo5 | #Key.mode_xen -> assert false
| `Firecracker -> "firecracker"
| `QEMU -> "qemu"
let build_context ?build_dir:_ i =
let target = Info.get i Key.target in
let build_context =
Dune.stanzaf
{|
(context
(default
(name %s)
(host default)
(toolchain unikraft)
(env
(_
(flags :standard -cclib "-z unikraft-backend=%s")
(c_flags :standard -z unikraft-backend=%s)))
(merlin)
(disable_dynamically_linked_foreign_archives true)))
|}
(context_name i) (unikraft_abi target) (unikraft_abi target)
in
[ build_context ]
let ext = function
| `Firecracker -> ".fc"
| `QEMU -> ".qemu"
| _ -> invalid_arg "Unikraft bindings only defined for Unikraft targets"
let main i = Fpath.(base (rem_ext (Info.main i)))
let out i =
let target = Info.get i Key.target in
let public_name =
match Info.output i with None -> Info.name i | Some o -> o
in
public_name ^ ext target
let rename i =
let out = out i in
let main = Fpath.to_string (main i) in
Dune.stanzaf
{|
(rule
(target %s)
(enabled_if (= %%{context_name} "%s"))
(deps %s.exe)
(action
(copy %s.exe %%{target})))
|}
out (context_name i) main main
let flags =
(* Disable "70 [missing-mli] Missing interface file." as we are only
generating .ml files currently. *)
[ ":standard"; "-w"; "-70" ]
@ if Misc.terminal () then [ "-color"; "always" ] else []
let main i =
let libraries = Info.libraries i in
let main = Fpath.to_string (main i) in
let pp_list f = Dune.compact_list f in
Dune.stanzaf
{|
(executable
(enabled_if
(= %%{context_name} "%s"))
(name %s)
(modes
(native exe))
(libraries %a)
(link_flags %a))
|}
(context_name i) main (pp_list "libraries") libraries
(pp_list "link_flags") flags
let dune i = [ main i; rename i ]
let out i =
let target = Info.get i Key.target in
let public_name =
match Info.output i with None -> Info.name i | Some o -> o
in
public_name ^ ext target
let install i =
let out = out i in
let open Fpath in
Install.v ~bin:[ (v out, v out) ] ()
end
let choose : Key.mode -> (module TARGET) = function
| #Solo5.t -> (module Solo5)
| #Unix.t -> (module Unix)
| #Unikraft.t -> (module Unikraft)
let dune i =
let target = Info.get i Key.target in
let (module Target) = choose target in
Target.dune i
let output_message = ref true
let configure i =
let open Action.Infix in
let target = Info.get i Key.target in
let (module Target) = choose target in
Target.configure i >|= fun () ->
if !output_message then (
output_message := false;
Logs.app (fun m ->
m
"Successfully configured the unikernel. Now run 'make' (or more \
fine-grained steps: 'make all', 'make depends', or 'make lock')."))
let build_context ?build_dir i =
let target = Info.get i Key.target in
let (module Target) = choose target in
Target.build_context ?build_dir i
let context_name i =
let target = Info.get i Key.target in
let (module Target) = choose target in
Target.context_name i
let out i =
let target = Info.get i Key.target in
let (module Target) = choose target in
Target.out i
let packages target =
let (module Target) = choose target in
Target.(packages (cast target))
let install i =
let target = Info.get i Key.target in
let (module Target) = choose target in
Target.install i

38
unikernel/duniverse/mirage/lib/devices/tcp.ml Normal file
View file

@ -0,0 +1,38 @@
open Functoria.DSL
open Functoria.Action
type 'a tcp = TCP
type tcpv4v6 = Ip.v4v6 tcp
let tcp = Functoria.Type.Type TCP
let tcpv4v6 : tcpv4v6 typ = tcp
(* this needs to be a function due to the value restriction. *)
let tcp_direct_func () =
let packages_v = Ip.right_tcpip_library ~sublibs:[ "tcp" ] "tcpip" in
let connect _ modname = function
| [ ip ] -> code ~pos:__POS__ "%s.connect %s" modname ip
| _ -> Misc.connect_err "tcp" 1
in
impl ~packages_v ~connect "Tcp.Flow.Make" (Ip.ip @-> tcp)
let direct_tcp ip = tcp_direct_func () $ ip
let tcpv4v6_socket_conf ~ipv4_only ~ipv6_only ipv4_key ipv6_key =
let v = Runtime_arg.v in
let runtime_args = [ v ipv4_only; v ipv6_only; v ipv4_key; v ipv6_key ] in
let packages_v =
Ip.right_tcpip_library ~sublibs:[ "tcpv4v6-socket" ] "tcpip"
in
let configure i =
match Misc.get_target i with
| `Unix | `MacOSX -> ok ()
| _ -> error "TCPv4v6 socket not supported on non-UNIX targets."
in
let connect _ modname = function
| [ ipv4_only; ipv6_only; ipv4_key; ipv6_key ] ->
code ~pos:__POS__ "%s.connect ~ipv4_only:%s ~ipv6_only:%s %s %s" modname
ipv4_only ipv6_only ipv4_key ipv6_key
| _ -> Misc.connect_err "tcpv4v6_socket_conf" 4
in
impl ~packages_v ~configure ~runtime_args ~connect "Tcpv4v6_socket" tcpv4v6

17
unikernel/duniverse/mirage/lib/devices/tcp.mli Normal file
View file

@ -0,0 +1,17 @@
open Functoria.DSL
type 'a tcp
val tcp : 'a tcp typ
type tcpv4v6 = Ip.v4v6 tcp
val tcpv4v6 : tcpv4v6 typ
val direct_tcp : 'a Ip.ip impl -> 'a tcp impl
val tcpv4v6_socket_conf :
ipv4_only:bool runtime_arg ->
ipv6_only:bool runtime_arg ->
Ipaddr.V4.Prefix.t runtime_arg ->
Ipaddr.V6.Prefix.t option runtime_arg ->
tcpv4v6 impl

38
unikernel/duniverse/mirage/lib/devices/udp.ml Normal file
View file

@ -0,0 +1,38 @@
module Action = Functoria.Action
open Functoria.DSL
type 'a udp = UDP
type udpv4v6 = Ip.v4v6 udp
let udp = Functoria.Type.Type UDP
let udpv4v6 : udpv4v6 typ = udp
(* Value restriction ... *)
let udp_direct_func () =
let packages_v = Ip.right_tcpip_library ~sublibs:[ "udp" ] "tcpip" in
let connect _ modname = function
| [ ip ] -> code ~pos:__POS__ "%s.connect %s" modname ip
| _ -> Misc.connect_err "udp" 1
in
impl ~packages_v ~connect "Udp.Make" (Ip.ip @-> udp)
let direct_udp ip = udp_direct_func () $ ip
let udpv4v6_socket_conf ~ipv4_only ~ipv6_only ipv4_key ipv6_key =
let v = Runtime_arg.v in
let runtime_args = [ v ipv4_only; v ipv6_only; v ipv4_key; v ipv6_key ] in
let packages_v =
Ip.right_tcpip_library ~sublibs:[ "udpv4v6-socket" ] "tcpip"
in
let configure i =
match Misc.get_target i with
| `Unix | `MacOSX -> Action.ok ()
| _ -> Action.error "UDPv4v6 socket not supported on non-UNIX targets."
in
let connect _ modname = function
| [ ipv4_only; ipv6_only; ipv4_key; ipv6_key ] ->
code ~pos:__POS__ "%s.connect ~ipv4_only:%s ~ipv6_only:%s %s %s" modname
ipv4_only ipv6_only ipv4_key ipv6_key
| _ -> Misc.connect_err "udpv4v6_socket_conf" 4
in
impl ~runtime_args ~packages_v ~configure ~connect "Udpv4v6_socket" udpv4v6

17
unikernel/duniverse/mirage/lib/devices/udp.mli Normal file
View file

@ -0,0 +1,17 @@
open Functoria.DSL
type 'a udp
val udp : 'a udp typ
type udpv4v6 = Ip.v4v6 udp
val udpv4v6 : udpv4v6 typ
val direct_udp : 'a Ip.ip impl -> 'a udp impl
val udpv4v6_socket_conf :
ipv4_only:bool runtime_arg ->
ipv6_only:bool runtime_arg ->
Ipaddr.V4.Prefix.t runtime_arg ->
Ipaddr.V6.Prefix.t option runtime_arg ->
udpv4v6 impl

3
unikernel/duniverse/mirage/lib/dune Normal file
View file

@ -0,0 +1,3 @@
(library
(public_name mirage)
(libraries ipaddr bos mirage.functoria mirage.devices))

70
unikernel/duniverse/mirage/lib/functoria/DSL.ml Normal file
View file

@ -0,0 +1,70 @@
(*
* 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.
*)
type 'a key = 'a Key.key
type 'a runtime_arg = 'a Runtime_arg.arg
type 'a value = 'a Key.value
type abstract_key = Key.t
type package = Package.t
type scope = Package.scope
type 'a typ = 'a Type.t
type 'a impl = 'a Impl.t
type abstract_impl = Impl.abstract
type 'a device = ('a, Impl.abstract) Device.t
type context = Context.t
type job = Job.t
type info = Info.t
type 'a code = 'a Device.code
let code = Device.code
let package = Package.v
let ( @-> ) = Type.( @-> )
let typ = Type.v
let ( $ ) = Impl.( $ )
let of_device = Impl.of_device
let key = Key.v
let dep = Impl.abstract
let if_impl = Impl.if_
let match_impl = Impl.match_
let impl ?packages ?packages_v ?local_libs ?install ?install_v ?keys
?runtime_args ?extra_deps ?connect ?dune ?configure ?files module_name
module_type =
of_device
@@ Device.v ?packages ?packages_v ?local_libs ?install ?install_v ?keys
?runtime_args ?extra_deps ?connect ?dune ?configure ?files module_name
module_type
let main ?pos ?packages ?packages_v ?local_libs ?runtime_args ?deps module_name
ty =
let connect _ = Device.start ?pos in
let extra_deps =
if Type.is_functor ty then deps
else
match deps with
| None | Some [] ->
print_endline
"adding unit argument to 'start ()' (to delay execution)";
Some [ dep Job.noop ]
| _ -> deps
in
impl ?packages ?packages_v ?local_libs ?runtime_args ?extra_deps ~connect
module_name ty
let runtime_arg ~pos ?packages str =
Runtime_arg.v (Runtime_arg.create ~pos ?packages str)

210
unikernel/duniverse/mirage/lib/functoria/DSL.mli Normal file
View file

@ -0,0 +1,210 @@
(*
* 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.
*)
(** The Functoria DSL allows users to describe how to create portable and
flexible applications. It allows to pass application parameters easily using
command-line arguments either at configure-time or at runtime.
Users of the Functoria DSL composes their application by defining a list of
{{!main} module} implementations, specify the command-line {!type-key} that
are required and {{!section-combinators} combine} all of them together using
{{:http://dx.doi.org/10.1017/S0956796807006326} applicative} operators.
The DSL expression is then compiled into an
{{!section-app} application builder}, which will, once evaluated, produced
the final portable and flexible application. *)
(** {1:combinators Combinators} *)
type 'a typ = 'a Type.t
(** The type for values representing module types. *)
val typ : 'a -> 'a typ
(** [type t] is a value representing the module type [t]. *)
val ( @-> ) : 'a typ -> 'b typ -> ('a -> 'b) typ
(** Construct a functor type from a type and an existing functor type. This
corresponds to prepending a parameter to the list of functor parameters. For
example:
{[
kv_ro @-> ip @-> kv_ro
]}
This describes a functor type that accepts two arguments -- a [kv_ro] and an
[ip] device -- and returns a [kv_ro]. *)
type 'a impl = 'a Impl.t
(** The type for values representing module implementations. *)
val ( $ ) : ('a -> 'b) impl -> 'a impl -> 'b impl
(** [m $ a] applies the functor [m] to the module [a]. *)
type abstract_impl = Impl.abstract
(** Same as {!type-impl} but with hidden type. *)
val dep : 'a impl -> abstract_impl
(** [dep t] is the (build-time) dependency towards [t]. *)
(** {1:keys Keys} *)
type 'a key = 'a Key.key
(** The type for configure-time command-line arguments. *)
type 'a runtime_arg = 'a Runtime_arg.arg
(** The type for runtime command-line arguments. *)
val runtime_arg :
pos:string * int * int * int ->
?packages:Package.t list ->
string ->
Runtime_arg.t
(** [runtime_arg ~pos ?packages v] is the runtime argument pointing to the value
[v]. [pos] is expected to be [__POS__]. [packages] specifies in which opam
package the value [v] is defined. *)
type abstract_key = Key.t
(** The type for abstract keys. *)
type context = Context.t
(** The type for keys' parsing context. See {!module-Key.type-context}. *)
type 'a value = 'a Key.value
(** The type for values parsed from the command-line. See {!Key.type-value}. *)
val key : 'a key -> Key.t
(** [key k] is an untyped representation of [k]. *)
val if_impl : bool value -> 'a impl -> 'a impl -> 'a impl
(** [if_impl v impl1 impl2] is [impl1] if [v] is resolved to true and [impl2]
otherwise. *)
val match_impl : 'b value -> default:'a impl -> ('b * 'a impl) list -> 'a impl
(** [match_impl v cases ~default] chooses the implementation amongst [cases] by
matching the [v]'s value. [default] is chosen if no value matches. *)
(** {1:pkg Package dependencies}
For specifying opam package dependencies, the type {!type-package} is used.
It consists of the opam package name, the ocamlfind names, and optional
lower and upper bounds. The version constraints are merged with other
modules. *)
type package = Package.t
(** The type for opam packages. *)
type scope = Package.scope
(** Installation scope of a package. *)
val package :
?scope:scope ->
?build:bool ->
?sublibs:string list ->
?libs:string list ->
?min:string ->
?max:string ->
?pin:string ->
?pin_version:string ->
string ->
package
(** [package ~scope ~build ~sublibs ~libs ~min ~max ~pin opam] is a [package].
[Build] indicates a build-time dependency only, defaults to [false]. The
library name is by default the same as [opam], you can specify [~sublibs] to
add additional sublibraries (e.g. [~sublibs:["mirage"] "foo"] will result in
the library names [["foo"; "foo.mirage"]]. In case the library name is
disjoint (or empty), use [~libs]. Specifying both [~libs] and [~sublibs]
leads to an invalid argument. Version constraints are given as [min]
(inclusive) and [max] (exclusive). If [pin] is provided, a
{{:https://opam.ocaml.org/doc/Manual.html#opamfield-pin-depends}
pin-depends} is generated, [pin_version] is ["dev"] by default. [~scope]
specifies the installation location of the package. *)
(** {1:app Application Builder}
Values of type {!type-impl} are tied to concrete module implementation with
the {!device} and {!main} construct. Module implementations of type
{!type-job} can then be {{!Functoria.Lib.Make.register} registered} into an
application builder. The builder is in charge if parsing the command-line
arguments and of generating code for the final application. See
{!Functoria.Lib} for details. *)
type info = Info.t
(** The type for build information. *)
val main :
?pos:string * int * int * int ->
?packages:package list ->
?packages_v:package list value ->
?local_libs:string list ->
?runtime_args:Runtime_arg.t list ->
?deps:abstract_impl list ->
string ->
'a typ ->
'a impl
(** [main name typ] is the functor [name], having the module type [typ]. The
connect code will call [<name>.start].
- If [packages] or [packages_v] is set, then the given packages are
installed before compiling the current application. *)
(** {1 Devices} *)
type 'a code = 'a Device.code
val code :
pos:string * int * int * int ->
('a, Format.formatter, unit, 'b code) format4 ->
'a
type 'a device = ('a, abstract_impl) Device.t
val of_device : 'a device -> 'a impl
(** [of_device t] is the implementation device [t]. *)
val impl :
?packages:package list ->
?packages_v:package list Key.value ->
?local_libs:string list ->
?install:(Info.t -> Install.t) ->
?install_v:(Info.t -> Install.t Key.value) ->
?keys:Key.t list ->
?runtime_args:Runtime_arg.t list ->
?extra_deps:abstract_impl list ->
?connect:(info -> string -> string list -> 'a code) ->
?dune:(info -> Dune.stanza list) ->
?configure:(info -> unit Action.t) ->
?files:(info -> Fpath.t list) ->
string ->
'a typ ->
'a impl
(** [impl ~packages ~packages_v ~install ~install_v ~keys ~runtime_args
~extra_deps ~connect ~dune ~configure ~files module_name module_type] is an
implementation of the device constructed by the arguments. [packages] and
[packages_v] are the dependencies (where [packages_v] is inside
{!Key.value}). [install] and [install_v] are the install instructions (used
in the generated opam file), [keys] are the configuration-time keys,
[runtime_args] the arguments at runtime, [extra_deps] are a list of extra
dependencies (other implementations), [connect] is the code emitted for
initializing the device, [dune] are dune stanzas added to the build rule,
[configure] are commands executed at the configuration phase, [files] are
files to be added to the list of generated files, [module_name] is the name
of the device module, and [module_type] is the type of the module. *)
(** {1 Jobs} *)
type job = Job.t

652
unikernel/duniverse/mirage/lib/functoria/action.ml Normal file
View file

@ -0,0 +1,652 @@
(*
* 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>
* Copyright (c) 2019-2020 Etienne Millon <etienne@tarides.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.
*)
let src = Logs.Src.create "functoria.action" ~doc:"functoria library"
module Log = (val Logs.src_log src : Logs.LOG)
open Astring
type 'a or_err = ('a, Rresult.R.msg) result
type tmp_name_pat = Bos.OS.File.tmp_name_pat
type 'a with_output = {
mode : int option;
path : Fpath.t;
purpose : string;
contents : Format.formatter -> 'a;
append : bool;
}
type channel = [ `Null | `Fmt of Format.formatter ]
type cmd = { cmd : Bos.Cmd.t; err : channel; out : channel; trim : bool }
type ls = { root : Fpath.t; filter : Fpath.t -> bool }
type _ command =
| Rmdir : Fpath.t -> unit command
| Mkdir : Fpath.t -> bool command
| Ls : ls -> Fpath.t list command
| Rm : Fpath.t -> unit command
| Is_file : Fpath.t -> bool command
| Is_dir : Fpath.t -> bool command
| Size_of : Fpath.t -> int option command
| Run_cmd : cmd -> unit command
| Run_cmd_out : cmd -> string command
| Run_cmd_cli : Bos.Cmd.t -> unit command
| Get_var : string -> string option command
| Set_var : string * string option -> unit command
| With_dir : Fpath.t * (unit -> 'a t) -> 'a command
| Pwd : Fpath.t command
| Tmp_file : int option * tmp_name_pat -> Fpath.t command
| Write_file : Fpath.t * string -> unit command
| Read_file : Fpath.t -> string command
| With_output : 'a with_output -> 'a command
and _ t =
| Done : 'a -> 'a t
| Fail : string -> 'a t
| Run : 'r command * ('r -> 'a t) -> 'a t
let ok x = Done x
let error e = Fail e
let errorf fmt = Fmt.kstr error fmt
let rec bind ~f = function
| Done r -> f r
| Fail s -> Fail s
| Run (c, k) ->
let k2 r = bind ~f (k r) in
Run (c, k2)
let map ~f x = bind x ~f:(fun y -> ok (f y))
let rec seq = function [] -> ok () | h :: t -> bind ~f:(fun () -> seq t) h
let wrap x = Run (x, ok)
let ( ! ) = Fpath.normalize
let rm path = wrap @@ Rm !path
let rmdir path = wrap @@ Rmdir !path
let mkdir path = wrap @@ Mkdir !path
let ls path filter = wrap @@ Ls { root = !path; filter }
let with_dir path f = wrap @@ With_dir (!path, f)
let pwd () = wrap @@ Pwd
let is_file path = wrap @@ Is_file !path
let is_dir path = wrap @@ Is_dir !path
let size_of path = wrap @@ Size_of !path
let set_var c v = wrap @@ Set_var (c, v)
let get_var c = wrap @@ Get_var c
let run_cmd ?(err = `Fmt Fmt.stderr) ?(out = `Fmt Fmt.stdout) cmd =
wrap @@ Run_cmd { cmd; out; err; trim = false }
let run_cmd_out ?(err = `Fmt Fmt.stderr) cmd =
wrap @@ Run_cmd_out { cmd; out = `Null; err; trim = true }
let run_cmd_cli cmd = wrap @@ Run_cmd_cli cmd
let write_file path contents = wrap @@ Write_file (!path, contents)
let read_file path = wrap @@ Read_file !path
let tmp_file ?mode pat = wrap @@ Tmp_file (mode, pat)
let with_output ?mode ?(append = false) ~path ~purpose contents =
wrap @@ With_output { append; mode; path; purpose; contents }
let pfo ppf s = match ppf with `Null -> () | `Fmt ppf -> Fmt.pf ppf "%s%!" s
let interpret_cmd { cmd; err; out; trim } =
Log.debug (fun l -> l "RUN: %a" Bos.Cmd.pp cmd);
let open Rresult in
let err =
match err with
| `Null -> Ok (Bos.OS.Cmd.err_null, fun () -> Ok ())
| `Fmt ppf ->
Bos.OS.File.tmp "cmd-err-%s" >>| fun path ->
let flush () = Bos.OS.File.read path >>| fun s -> Fmt.pf ppf "%s%!" s in
(Bos.OS.Cmd.err_file path, flush)
in
err >>= fun (err, flush_err) ->
let res = Bos.OS.Cmd.run_out ~err cmd in
let res = Bos.OS.Cmd.out_string ~trim res in
res >>= fun (str_out, _) ->
pfo out str_out;
flush_err () >>= fun () -> Bos.OS.Cmd.success res
let interpret_cmd_cli cmd =
Log.debug (fun l -> l "RUN-CLI: %a" Bos.Cmd.pp cmd);
let res = Bos.OS.Cmd.run_out cmd in
match Bos.OS.Cmd.out_stdout res with
| Ok ((), (_, `Exited 0)) -> Ok ()
| Ok ((), (_, `Exited _)) -> Error (`Msg "")
| failure -> Bos.OS.Cmd.success failure
let rec interpret_command : type r. r command -> r or_err = function
| Rmdir path ->
Log.debug (fun l -> l "rmdir %a" Fpath.pp path);
Bos.OS.Dir.delete ~recurse:true path
| Mkdir path ->
Log.debug (fun l -> l "mkdir %a" Fpath.pp path);
Bos.OS.Dir.create ~path:true path
| Ls { root; filter } ->
let open Rresult in
Log.debug (fun l -> l "ls %a" Fpath.pp root);
Bos.OS.Path.matches ~dotfiles:true Fpath.(root / "$(file)")
>>| fun files -> List.filter filter files
| Rm path ->
Log.debug (fun l -> l "rm %a" Fpath.pp path);
Bos.OS.File.delete ~must_exist:false path
| Is_file path ->
Log.debug (fun l -> l "is-file %a" Fpath.pp path);
Bos.OS.File.exists path
| Is_dir path ->
Log.debug (fun l -> l "is-dir %a" Fpath.pp path);
Bos.OS.Dir.exists path
| Size_of path -> (
Log.debug (fun l -> l "size-of %a" Fpath.pp path);
match Bos.OS.Path.stat path with
| Ok s -> Ok (Some s.Unix.st_size)
| _ -> Ok None)
| Run_cmd cmd -> Rresult.(interpret_cmd cmd >>| fun _ -> ())
| Run_cmd_out cmd -> interpret_cmd cmd
| Run_cmd_cli cmd -> interpret_cmd_cli cmd
| Set_var (c, v) ->
Log.debug (fun l ->
l "set_var %s %a" c Fmt.(option ~none:(any "<unset>") string) v);
Bos.OS.Env.set_var c v
| Get_var c ->
Log.debug (fun l -> l "get_var %s" c);
Ok (Bos.OS.Env.var c)
| With_dir (dir, f) ->
let f () = run (f ()) in
let open Rresult in
Bos.OS.Dir.current () >>= fun old ->
Log.debug (fun l -> l "entering %a" Fpath.pp dir);
Rresult.R.join @@ Bos.OS.Dir.with_current dir f () >>| fun r ->
Log.debug (fun l -> l "entering %a" Fpath.pp old);
r
| Pwd ->
Log.debug (fun l -> l "pwd");
Bos.OS.Dir.current ()
| Write_file (path, contents) ->
Log.debug (fun l -> l "write %a" Fpath.pp path);
Bos.OS.File.write path contents
| Read_file path ->
Log.debug (fun l -> l "read-file %a" Fpath.pp path);
Bos.OS.File.read path
| Tmp_file (mode, pat) ->
Log.debug (fun l -> l "tmp-file %s" Fmt.(str pat "*"));
Bos.OS.File.tmp ?mode pat
| With_output { mode; path; purpose; contents; append } -> (
try
let oc =
let path = Fpath.to_string path in
let mode = match mode with None -> 0o666 | Some m -> m in
if append then
open_out_gen [ Open_wronly; Open_append; Open_text ] mode path
else open_out path
in
let ppf = Format.formatter_of_out_channel oc in
let r = contents ppf in
Fmt.pf ppf "%!";
flush oc;
close_out oc;
Ok r
with e ->
Rresult.R.error_msgf "couldn't open output channel for %s: %a" purpose
Fmt.exn e)
and run : type r. r t -> r or_err = function
| Done r -> Ok r
| Fail f -> Error (`Msg f)
| Run (cmd, k) -> Rresult.R.bind (interpret_command cmd) (fun x -> run @@ k x)
type files = [ `Passtrough of Fpath.t | `Files of (Fpath.t * string) list ]
let default_exec cmd =
let cmd =
Fmt.str "$(%a)\n" Fmt.(list ~sep:(any " ") string) (Bos.Cmd.to_list cmd)
in
Some (cmd, "")
(* (simple) virtual environment *)
module Env : sig
type t
val eq : t -> t -> bool
val pp : t Fmt.t
val diff_files : old:t -> t -> Fpath.Set.t
val pwd : t -> Fpath.t
val chdir : t -> Fpath.t -> t
val ls : t -> Fpath.t -> Fpath.t list option
val v :
?exec:(Bos.Cmd.t -> (string * string) option) ->
?env:(string * string) list ->
?pwd:Fpath.t ->
?files:files ->
unit ->
t
val exec : t -> Bos.Cmd.t -> (string * string) option
val is_file : t -> Fpath.t -> bool
val is_dir : t -> Fpath.t -> bool
val mkdir : t -> Fpath.t -> (t * bool) option
val rm : t -> Fpath.t -> (t * bool) option
val rmdir : t -> Fpath.t -> t
val size_of : t -> Fpath.t -> int option
val write : t -> Fpath.t -> string -> t
val read : t -> Fpath.t -> string option
val tmp_file : t -> tmp_name_pat -> Fpath.t
val set_var : t -> string -> string option -> t
val get_var : t -> string -> string option
end = struct
type t = {
files : string Fpath.Map.t;
pwd : Fpath.t;
env : string String.Map.t;
exec : Bos.Cmd.t -> (string * string) option;
}
let diff_files ~old t =
let to_set t =
Fpath.Map.fold
(fun f _ acc ->
match Fpath.rem_prefix t.pwd f with
| None -> acc
| Some f -> Fpath.Set.add f acc)
t.files Fpath.Set.empty
in
Fpath.Set.diff (to_set t) (to_set old)
let scan dir =
(let open Rresult in
Bos.OS.Path.fold ~dotfiles:true ~elements:`Files ~traverse:`Any
(fun file files ->
files >>= fun files ->
Bos.OS.File.read file >>| fun c -> (file, c) :: files)
(Ok []) [ dir ])
|> Rresult.R.join
|> Rresult.R.error_msg_to_invalid_arg
let v ?(exec = default_exec) ?env ?pwd ?(files = `Files []) () =
let env =
match env with Some e -> String.Map.of_list e | None -> String.Map.empty
in
let pwd = match pwd with None -> Fpath.v "/" | Some p -> p in
let files =
let files =
match files with `Passtrough dir -> scan dir | `Files files -> files
in
let files =
List.map
(fun (f, c) ->
match Fpath.is_rel f with
| false -> (f, c)
| true -> (Fpath.(pwd // f), c))
files
in
List.map (fun (f, c) -> (Fpath.normalize f, c)) files
in
{ files = Fpath.Map.of_list files; pwd; env; exec }
let eq x y =
Fpath.Map.equal ( = ) x.files y.files
&& Fpath.equal x.pwd y.pwd
&& String.Map.equal ( = ) x.env y.env
let pp =
let open Fmt.Dump in
record
[
field "files" (fun t -> t.files) (Fpath.Map.dump string);
field "pwd" (fun t -> t.pwd) Fpath.dump;
field "env" (fun t -> t.env) (String.Map.dump string);
]
let pwd t = t.pwd
let exec t cmd = t.exec cmd
let mk_path t path =
match (Fpath.to_string t.pwd, Fpath.is_rel path) with
| _, true -> Fpath.(normalize @@ (t.pwd // path))
| _, false -> Fpath.normalize path
let chdir t path =
let pwd = mk_path t path in
{ t with pwd }
let is_root path = Fpath.to_string path = "/"
let mkdir t path =
let path = mk_path t path in
if is_root path then Some (t, false)
else
match Fpath.Map.find path t.files with
| Some f when f <> "<DIR>" -> None
| r ->
let t = { t with files = Fpath.Map.add path "<DIR>" t.files } in
Some (t, r = None)
let rmdir t path =
let path = mk_path t path in
let files =
Fpath.Map.filter
(fun f _ ->
let f = mk_path t f in
let b = not (Fpath.is_prefix path f) in
b)
t.files
in
{ t with files }
let ls t path =
let root = mk_path t path in
match Fpath.Map.find root t.files with
| Some "<DIR>" -> Some []
| Some _ -> Some [ path ]
| None -> (
Fpath.Map.fold
(fun file _ acc ->
let file = mk_path t file in
match Fpath.relativize ~root file with
| None -> acc
| Some f -> f :: acc)
t.files []
|> function
| [] -> None
| x -> Some (List.rev x))
let write t path f =
let path = mk_path t path in
{ t with files = Fpath.Map.add path f t.files }
let read t path =
let path = mk_path t path in
Fpath.Map.find path t.files
let tmp_file t pat =
let rec aux n =
let dir = Fpath.v "/tmp" in
let file = Fpath.(dir / Fmt.str pat (string_of_int n)) in
if Fpath.Map.mem file t.files then aux (n + 1) else file
in
aux 0
let is_dir t path =
let path = mk_path t path in
match Fpath.Map.find path t.files with
| Some "<DIR>" -> true
| Some _ -> false
| None ->
Fpath.Map.exists
(fun f _ ->
let f = mk_path t f in
Fpath.is_prefix path f)
t.files
let is_file t path =
let path = mk_path t path in
match Fpath.Map.find path t.files with
| Some "<DIR>" | None -> false
| Some _ -> true
let rm t path =
let path = mk_path t path in
match Fpath.Map.find path t.files with
| Some "<DIR>" -> None
| Some _ -> Some ({ t with files = Fpath.Map.remove path t.files }, true)
| None -> if is_dir t path then None else Some (t, false)
let size_of t path =
let path = mk_path t path in
match Fpath.Map.find path t.files with
| None -> None
| Some "<DIR>" -> Some 0
| Some f -> Some (String.length f)
let set_var t c = function
| None -> { t with env = String.Map.remove c t.env }
| Some v -> { t with env = String.Map.add c v t.env }
let get_var t c = String.Map.find c t.env
end
let error_msg = Rresult.R.error_msgf
type env = Env.t
let env = Env.v
type 'a domain = { result : 'a or_err; env : Env.t; logs : string list }
let pp_or_err pp_a = Rresult.R.pp ~error:Rresult.R.pp_msg ~ok:pp_a
let eq_or_err eq_a = Rresult.R.equal ~error:( = ) ~ok:eq_a
let pp_domain pp_a =
let open Fmt.Dump in
record
[
field "result" (fun t -> t.result) (pp_or_err pp_a);
field "env" (fun t -> t.env) Env.pp;
field "logs" (fun t -> t.logs) Fmt.Dump.(list string);
]
let eq_domain eq a b =
eq_or_err eq a.result b.result && Env.eq a.env b.env && a.logs = b.logs
let dom result env logs = { result; env; logs }
let interpret_dry_cmd env { cmd; err; out; _ } : string domain =
Log.debug (fun l -> l "Run_cmd '%a'" Bos.Cmd.pp cmd);
let log x = Fmt.str "Run_cmd '%a' (%s)" Bos.Cmd.pp cmd x in
match Env.exec env cmd with
| None -> dom (error_msg "'%a' not found" Bos.Cmd.pp cmd) env [ log "error" ]
| Some (o, e) ->
pfo out o;
pfo err e;
dom (Ok o) env [ log "ok" ]
let interpret_dry_cmd_cli env cmd : unit domain =
Log.debug (fun l -> l "Run_cmd_cli '%a'" Bos.Cmd.pp cmd);
let log x = Fmt.str "Run_cmd_cli '%a' (%s)" Bos.Cmd.pp cmd x in
match Env.exec env cmd with
| None -> dom (error_msg "'%a' not found" Bos.Cmd.pp cmd) env [ log "error" ]
| Some _ -> dom (Ok ()) env [ log "ok" ]
let rec interpret_dry : type r. env:Env.t -> r command -> r domain =
fun ~env -> function
| Mkdir path -> (
Log.debug (fun l -> l "Mkdir %a" Fpath.pp path);
let log s = Fmt.str "Mkdir %a (%s)" Fpath.pp path s in
match Env.mkdir env path with
| Some (env, true) -> dom (Ok true) env [ log "created" ]
| Some (env, false) -> dom (Ok false) env [ log "already exists" ]
| None ->
dom
(error_msg "a file named '%a' already exists" Fpath.pp path)
env
[ log "error" ])
| Rmdir path ->
Log.debug (fun l -> l "Rmdir %a" Fpath.pp path);
let log s = Fmt.str "Rmdir %a (%s)" Fpath.pp path s in
if Env.is_dir env path || Env.is_file env path then
dom (Ok ()) (Env.rmdir env path) [ log "removed" ]
else dom (Ok ()) env [ log "no-op" ]
| Ls { root; filter } -> (
Log.debug (fun l -> l "Ls %a" Fpath.pp root);
let logs fmt = Fmt.kstr (Fmt.str "Ls %a (%s)" Fpath.pp root) fmt in
match Env.ls env root with
| None ->
dom
(error_msg "%a: no such file or directory" Fpath.pp root)
env
[ logs "error" ]
| Some es -> (
match List.filter filter es with
| ([] | [ _ ]) as e ->
dom (Ok e) env [ logs "%d entry" (List.length e) ]
| es -> dom (Ok es) env [ logs "%d entries" (List.length es) ]))
| Rm path -> (
Log.debug (fun l -> l "Rm %a" Fpath.pp path);
let log s = Fmt.str "Rm %a (%s)" Fpath.pp path s in
match Env.rm env path with
| Some (env, b) ->
dom (Ok ()) env [ log (if b then "removed" else "no-op") ]
| None ->
dom (error_msg "%a is a directory" Fpath.pp path) env [ log "error" ])
| Is_file path ->
Log.debug (fun l -> l "Is_file %a" Fpath.pp path);
let r = Env.is_file env path in
dom (Ok r) env [ Fmt.str "Is_file? %a -> %b" Fpath.pp path r ]
| Is_dir path ->
Log.debug (fun l -> l "Is_dir %a" Fpath.pp path);
let r = Env.is_dir env path in
dom (Ok r) env [ Fmt.str "Is_dir? %a -> %b" Fpath.pp path r ]
| Size_of path ->
Log.debug (fun l -> l "Size_of %a" Fpath.pp path);
let r = Env.size_of env path in
dom (Ok r) env
[
Fmt.str "Size_of %a -> %a" Fpath.pp path
Fmt.(option ~none:(any "error") int)
r;
]
| Run_cmd cmd -> (
let domain = interpret_dry_cmd env cmd in
match domain.result with
| Ok _ -> { domain with result = Ok () }
| Error _ as r -> { domain with result = r })
| Run_cmd_out cmd -> interpret_dry_cmd env cmd
| Run_cmd_cli cmd -> interpret_dry_cmd_cli env cmd
| Write_file (path, s) ->
Log.debug (fun l -> l "Write_file %a" Fpath.pp path);
dom (Ok ()) (Env.write env path s)
[ Fmt.str "Write to %a (%d bytes)" Fpath.pp path (String.length s) ]
| Read_file path -> (
Log.debug (fun l -> l "Read_file %a" Fpath.pp path);
match Env.read env path with
| None ->
let log = Fmt.str "Read: %a" Fpath.pp path in
dom (error_msg "read_file: file does not exist") env [ log ]
| Some r ->
let log =
Fmt.str "Read %a (%d bytes)" Fpath.pp path (String.length r)
in
dom (Ok r) env [ log ])
| Tmp_file (_, pat) ->
Log.debug (fun l -> l "Tmp_file %s" Fmt.(str pat "*"));
let r = Env.tmp_file env pat in
dom (Ok r) env [ Fmt.str "Tmp_file -> %a" Fpath.pp r ]
| Set_var (c, v) ->
Log.debug (fun l ->
l "Set_var %s %a" c Fmt.(option ~none:(any "<none>") string) v);
let env = Env.set_var env c v in
let log =
Fmt.str "Set_var %s %a" c Fmt.(option ~none:(any "<unset>") string) v
in
dom (Ok ()) env [ log ]
| Get_var c ->
Log.debug (fun l -> l "Get_var %s" c);
let v = Env.get_var env c in
let log =
Fmt.str "Get_var %s -> %a" c
Fmt.(option ~none:(any "<not set>") string)
v
in
dom (Ok v) env [ log ]
| With_dir (dir, f) ->
Log.debug (fun l -> l "With_dir %a" Fpath.pp dir);
let old = Env.pwd env in
let env = Env.chdir env dir in
let domain = dry_run ~env (f ()) in
let env = Env.chdir domain.env old in
let log =
Fmt.str "With_dir %a [%a]" Fpath.pp dir
Fmt.(vbox ~indent:2 (list ~sep:(any "@,") string))
domain.logs
in
{ domain with env; logs = [ log ] }
| Pwd ->
Log.debug (fun l -> l "Pwd");
let r = Env.pwd env in
dom (Ok r) env [ Fmt.str "Pwd -> %a" Fpath.pp r ]
| With_output { mode; path; purpose; contents; append } ->
let pp_append ppf () = if append then Fmt.string ppf "[append]" else () in
Log.debug (fun l ->
l "With_output%a %a (%s)" pp_append () Fpath.pp path purpose);
let buf = Buffer.create 0 in
let fmt = Format.formatter_of_buffer buf in
let pp_mode fmt = function
| None -> Format.fprintf fmt "default"
| Some n -> Format.fprintf fmt "%#o" n
in
let r = contents fmt in
Fmt.pf fmt "%!";
let f = Buffer.contents buf in
let log =
Fmt.str "Write to %a (mode: %a, purpose: %s)" Fpath.pp path pp_mode mode
purpose
in
dom (Ok r) (Env.write env path f) [ log ]
and dry_run : type r. env:Env.t -> r t -> r domain =
fun ~env t ->
let rec go t ~env log =
match t with
| Done r -> dom (Ok r) env log
| Fail e -> dom (Error (`Msg e)) env log
| Run (cmd, k) -> (
let domain = interpret_dry ~env cmd in
let new_log = List.rev domain.logs @ log in
match domain.result with
| Ok x -> go (k x) ~env:domain.env new_log
| Error _ as e -> dom e domain.env new_log)
in
let domain = go t ~env [] in
{ domain with logs = List.rev domain.logs }
let dry_run ?(env = env ()) t = dry_run ~env t
let dry_run_trace ?env t =
let domain = dry_run ?env t in
List.iter print_endline domain.logs
let generated_files ?(env = env ~exec:(fun _ -> None) ()) t =
let domain = dry_run ~env t in
Env.diff_files ~old:env domain.env
module Infix = struct
let ( >>= ) x f = bind ~f x
let ( >|= ) x f = map ~f x
end
module Syntax = struct
open Infix
let ( let* ) = ( >>= )
let ( let+ ) = ( >|= )
end
module List = struct
open Infix
let iter ~f l = List.fold_left (fun acc e -> acc >>= fun () -> f e) (ok ()) l
let map ~f l =
List.fold_left
(fun acc e ->
acc >>= fun acc ->
f e >|= fun e -> e :: acc)
(ok []) l
end

182
unikernel/duniverse/mirage/lib/functoria/action.mli Normal file
View file

@ -0,0 +1,182 @@
(*
* 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>
* Copyright (c) 2019-2020 Etienne Millon <etienne@tarides.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.
*)
(** Wrapper around [Bos] which provides a "dry run" feature. *)
(** {1 The action type} *)
type 'a t
(** An action that when executed may return a value of type ['a]. *)
val ok : 'a -> 'a t
(** An action that returns a value. *)
val error : string -> 'a t
(** [error e] is the failed action with error message [e]. *)
val errorf : ('a, Format.formatter, unit, 'b t) format4 -> 'a
(** [errorf fmt] is the failed action with error message [fmt]. *)
val map : f:('a -> 'b) -> 'a t -> 'b t
(** Functor instance. *)
val bind : f:('a -> 'b t) -> 'a t -> 'b t
(** Monad instance. *)
val seq : unit t list -> unit t
(** [seq t] runs the elements of [t] in sequence. *)
module List : sig
val iter : f:('a -> unit t) -> 'a list -> unit t
val map : f:('a -> 'b t) -> 'a list -> 'b list t
end
module Infix : sig
val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t
end
module Syntax : sig
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
end
(** {1 Actions} *)
val rm : Fpath.t -> unit t
(** Delete a file. (see [Bos.OS.File.delete]) *)
val mkdir : Fpath.t -> bool t
(** Create a directory. (See [Bos.OS.Dir.create] *)
val rmdir : Fpath.t -> unit t
(** Remove a directory. (see [Bos.OS.Dir.delete]) *)
val with_dir : Fpath.t -> (unit -> 'a t) -> 'a t
(** [with_dir d f] runs [f] with [d] as current working directory. (See
[Bos.OS.Dir.with_current]). *)
val pwd : unit -> Fpath.t t
(** [pwd ()] is the current working directory. (See [Bos.OS.Dir.current]) *)
val is_file : Fpath.t -> bool t
(** Does a file exist? (see [Bos.OS.File.exists]) *)
val is_dir : Fpath.t -> bool t
(** Does a directory exist? (see [Bos.OS.Dir.exists]) *)
val size_of : Fpath.t -> int option t
(** [size_of f] is [Some i] if [f] exists and is of size [i], and [None] if [f]
doesn't exist. *)
val set_var : string -> string option -> unit t
(** [set_var v c] sets env variable [c] to [c]. (see [Bos.OS.Env.set_var]) *)
val get_var : string -> string option t
(** [get_var v] gets the value of the variable [c] in the environment. (see
[Bos.OS.Env.get]) *)
type channel = [ `Null | `Fmt of Format.formatter ]
(** The type for channels. *)
val run_cmd : ?err:channel -> ?out:channel -> Bos.Cmd.t -> unit t
(** Run a command. By default, [err] is [Fmt.stderr] and [out] is [Fmt.stdout].
(see [Bos.OS.Cmd.run]) *)
val run_cmd_out : ?err:channel -> Bos.Cmd.t -> string t
(** Run a command and return its trimmed stdout. By default [err] is
[Fmt.stderr]. (See [Bos.OS.Cmd.run_out]) *)
val run_cmd_cli : Bos.Cmd.t -> unit t
(** Run a command as a command line interface, meaning stdout and stderr remain
untouched. *)
val write_file : Fpath.t -> string -> unit t
(** Write some data to a file. (see [Bos.OS.File.write]) *)
val read_file : Fpath.t -> string t
(** [read_file f] is [f]'s contents. (see [Bos.OS.File.read]) *)
val tmp_file : ?mode:int -> Bos.OS.File.tmp_name_pat -> Fpath.t t
(** [tmp_file pat] is a tempory file built using the pattern [pat]. (See
[Bos.OS.File.tmp]) *)
val ls : Fpath.t -> (Fpath.t -> bool) -> Fpath.t list t
(** [ls dir] is the list of files in [dir]. *)
val with_output :
?mode:int ->
?append:bool ->
path:Fpath.t ->
purpose:string ->
(Format.formatter -> 'a) ->
'a t
(** Open a file with a given mode, and write some data to it through a function.
(see [Bos.OS.File.with_oc]). [purpose] is used in error messages. If
[append] is set (by default it is not), the data is appended to [path]. *)
(** {1 Interpreters} *)
val run : 'a t -> ('a, Rresult.R.msg) result
(** Run the command through [Bos]. *)
type env
(** The type for virtual environments. *)
type files = [ `Passtrough of Fpath.t | `Files of (Fpath.t * string) list ]
val default_exec : Bos.Cmd.t -> (string * string) option
(** [default_exec cmd] is [Some ("$(<cmd>)", "")]. *)
val env :
?exec:(Bos.Cmd.t -> (string * string) option) ->
?env:(string * string) list ->
?pwd:Fpath.t ->
?files:files ->
unit ->
env
type 'a domain = {
result : ('a, Rresult.R.msg) result;
env : env;
logs : string list;
}
(** The type for interpreted values. *)
val eq_domain : ('a -> 'a -> bool) -> 'a domain -> 'a domain -> bool
(** [eq_domain] is the equality function between {!domain}s. *)
val pp_domain : 'a Fmt.t -> 'a domain Fmt.t
(** [pp_domain] is the pretty-printer for {!domain}s. *)
val dry_run : ?env:env -> 'a t -> 'a domain
(** Emulate the action. This will not do IO on the actual files. Some
approximation is done to determine the result of actions. [files] is a list
of paths that are supposed to exist at the beginning. Returns:
- the result of the action (which can be an [Bos] error)
- the list of files after execution
- a trace (list of log messages) *)
val dry_run_trace : ?env:env -> 'a t -> unit
(** Only output the trace part of [dry_run]. *)
val generated_files : ?env:env -> 'a t -> Fpath.Set.t
(** [generated_files t] is the set of files created by [t]. Note: this might be
incomplete/incorrect in case of calls to external commands. *)

25
unikernel/duniverse/mirage/lib/functoria/argv.ml Normal file
View file

@ -0,0 +1,25 @@
(*
* 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.
*)
type t = ARGV
let argv = Type.v ARGV
let sys_argv =
let connect _ _ _ = Device.code ~pos:__POS__ "return Sys.argv" in
Impl.v ~connect "Sys" argv

29
unikernel/duniverse/mirage/lib/functoria/argv.mli Normal file
View file

@ -0,0 +1,29 @@
(*
* 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.
*)
(** Device representing the command line. *)
type t
(** The type for command-line arguments, similar to the usual [Sys.argv]. *)
val argv : t Type.t
(** [argv] is a value representing {!argv} module types. *)
val sys_argv : t Impl.t
(** [sys_argv] is a device providing command-line arguments by using
{!Sys.argv}. *)

591
unikernel/duniverse/mirage/lib/functoria/cli.ml Normal file
View file

@ -0,0 +1,591 @@
(*
* 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.
*)
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ())
open Cmdliner
let common_section = "COMMON OPTIONS"
let configuration_section = "CONFIGURE OPTIONS"
let query_section = "QUERY OPTIONS"
let description_section = "DESCRIBE OPTIONS"
type query_kind =
[ `Name
| `Packages
| `Opam
| `Files
| `Dune of [ `Config | `Build | `Project | `Workspace | `Dist ]
| `Makefile ]
let query_kinds : (string * query_kind) list =
[
("name", `Name);
("packages", `Packages);
("opam", `Opam);
("files", `Files);
("Makefile", `Makefile);
("dune.config", `Dune `Config);
("dune.build", `Dune `Build);
("dune-project", `Dune `Project);
("dune-workspace", `Dune `Workspace);
("dune.dist", `Dune `Dist);
]
let setup ~with_setup =
Term.(
const (if with_setup then setup_log else fun _ _ -> ())
$ Fmt_cli.style_renderer ~docs:common_section ()
$ Logs_cli.level ~docs:common_section ())
let config_file =
let doc =
Arg.info ~docs:configuration_section ~docv:"FILE"
~doc:"The configuration file to use."
[ "f"; "file"; "config-file" ]
in
Term.(const Fpath.v $ Arg.(value & opt string "config.ml" & doc))
let map_default ~default f x = if x == default then None else Some (f x)
let context_file mname =
let doc =
Arg.info ~docs:configuration_section ~docv:"FILE"
~doc:"The context file to use." [ "context-file" ]
in
let default = mname ^ ".context" in
Term.(
const (map_default ~default Fpath.v)
$ Arg.(value & opt string default & doc))
let extra_repos doc_section =
let key =
let parser str =
match Astring.String.cut ~sep:":" str with
| Some (name, repository) -> Ok (name, repository)
| None ->
Rresult.R.error_msgf
"Invalid extra repository argument (expected <name>:<repository>)"
in
let pp ppf (name, repository) = Fmt.pf ppf "%s:%s" name repository in
Arg.conv (parser, pp)
in
let env = Cmd.Env.info "MIRAGE_EXTRA_REPOS" in
let doc =
Arg.info ~docs:doc_section ~docv:"NAME1:URL1,NAME2:URL2,..." ~env
~doc:
"Additional opam-repositories to use when using `opam monorepo lock' \
to gather local sources. Default: \
https://github.com/dune-universe/opam-overlays.git & \
https://github.com/dune-universe/mirage-opam-overlays.git."
[ "extra-repos" ]
in
Arg.(
value
& opt (list key)
[
("opam-overlays", "https://github.com/dune-universe/opam-overlays.git");
( "mirage-overlays",
"https://github.com/dune-universe/mirage-opam-overlays.git" );
]
& doc)
let no_extra_repo doc_section =
let doc =
Arg.info ~docs:doc_section ~doc:"Disable the use of any overlay repository."
[ "no-extra-repo" ]
in
Arg.(value & flag & doc)
let extra_repos doc_section =
let ex = extra_repos doc_section in
let no_ex = no_extra_repo doc_section in
Term.(const (fun ex no_ex -> if no_ex then [] else ex) $ ex $ no_ex)
let dry_run =
let doc =
Arg.info ~docs:configuration_section
~doc:"Display I/O actions instead of executing them." [ "dry-run" ]
in
Arg.(value & flag doc)
(** * Argument specifications *)
(** Argument specification for --depext *)
let depext section =
let depext_doc =
Arg.info ~docs:section [ "depext" ]
~doc:"Enable call to `opam depext' in the project Makefile."
in
let no_depext_doc =
Arg.info ~docs:section [ "no-depext" ]
~doc:"Disable call to `opam depext' in the project Makefile."
in
let eval_opts = [ (true, depext_doc); (false, no_depext_doc) ] in
Arg.(value & vflag true eval_opts)
(** Argument specification for --eval *)
let full_eval =
let eval_doc =
Arg.info ~docs:description_section [ "eval" ]
~doc:
"Fully evaluate the graph before showing it. The default when the \
unikernel has already been configured."
in
let no_eval_doc =
Arg.info ~docs:description_section [ "no-eval" ]
~doc:
"Do not evaluate the graph before showing it. See $(b,--eval). The \
default when the unikernel has not been configured."
in
let eval_opts = [ (Some true, eval_doc); (Some false, no_eval_doc) ] in
Arg.(value & vflag None eval_opts)
(** Argument specification for --dot *)
let dot =
let doc =
Arg.info ~docs:description_section [ "dot" ]
~doc:
"Output a dot description. If no output file is given, it will display \
the dot file using the command given to $(b,--dot-command). Use in \
combination with $(b,--output=-) (short version: $(b,-o-)) to display \
the dot file on stdout."
in
Arg.(value & flag doc)
(** Argument specification for --dot-command=COMMAND *)
let dotcmd =
let doc =
Arg.info ~docs:description_section ~docv:"COMMAND" [ "dot-command" ]
~doc:
"Command used to show a dot file. This command should accept a dot \
file on its standard input."
in
Arg.(value & opt string "xdot" & doc)
(** Argument specification for -o FILE or --output=FILE *)
let output =
let doc =
Arg.info ~docs:configuration_section ~docv:"FILE" [ "o"; "output" ]
~doc:"Name of the output file."
in
Arg.(value & opt (some string) None & doc)
let kind =
let enums = Arg.doc_alts_enum ~quoted:true query_kinds in
let doc =
Arg.info ~docs:configuration_section ~docv:"INFO" []
~doc:(Fmt.str "The information to query. $(docv) must be %s" enums)
in
Arg.(value & pos 0 (enum query_kinds) `Packages & doc)
type 'a args = {
context : 'a;
config_file : Fpath.t;
context_file : Fpath.t option;
output : string option;
dry_run : bool;
}
let default_args =
{
context = ();
config_file = Fpath.v "dummy";
context_file = None;
output = None;
dry_run = false;
}
type 'a configure_args = {
args : 'a args;
depext : bool;
extra_repo : (string * string) list;
}
type 'a build_args = 'a args
type 'a clean_args = 'a args
type 'a help_args = 'a args
type 'a describe_args = {
args : 'a args;
dotcmd : string;
dot : bool;
eval : bool option;
}
type 'a query_args = {
args : 'a args;
kind : query_kind;
depext : bool;
extra_repo : (string * string) list;
}
type 'a action =
| Configure of 'a configure_args
| Query of 'a query_args
| Describe of 'a describe_args
| Clean of 'a clean_args
| Help of 'a help_args
(*
* Pretty-printing
*)
let pp_args pp_a =
let open Fmt.Dump in
record
[
field "context" (fun (t : 'a args) -> t.context) pp_a;
field "config_file" (fun t -> t.config_file) Fpath.pp;
field "output" (fun t -> t.output) (option string);
field "dry_run" (fun t -> t.dry_run) Fmt.bool;
]
let pp_configure pp_a =
let open Fmt.Dump in
record
[
field "args" (fun (t : 'a configure_args) -> t.args) (pp_args pp_a);
field "depext" (fun (t : 'a configure_args) -> t.depext) Fmt.bool;
]
let pp_clean = pp_args
let pp_help = pp_args
let pp_query_kind ppf (q : query_kind) =
let rec aux = function
| [] -> invalid_arg "missing query kind!"
| (a, b) :: t -> if b = q then Fmt.string ppf a else aux t
in
aux query_kinds
let pp_query pp_a =
let open Fmt.Dump in
record
[
field "args" (fun (t : 'a query_args) -> t.args) (pp_args pp_a);
field "kind" (fun t -> t.kind) pp_query_kind;
field "depext" (fun t -> t.depext) Fmt.bool;
]
let pp_describe pp_a =
let open Fmt.Dump in
record
[
field "args" (fun (t : 'a describe_args) -> t.args) (pp_args pp_a);
field "dotcmd" (fun t -> t.dotcmd) string;
field "dot" (fun t -> t.dot) Fmt.bool;
field "eval" (fun t -> t.eval) (option Fmt.bool);
]
let pp_action pp_a ppf = function
| Configure c -> Fmt.pf ppf "@[configure:@ @[<2>%a@]@]" (pp_configure pp_a) c
| Query q -> Fmt.pf ppf "@[query:@ @[<2>%a@]@]" (pp_query pp_a) q
| Describe d -> Fmt.pf ppf "@[describe:@ @[<2>%a@]@]" (pp_describe pp_a) d
| Clean c -> Fmt.pf ppf "@[clean:@ @[<2>%a@]@]" (pp_clean pp_a) c
| Help h -> Fmt.pf ppf "@[help:@ @[<2>%a@]@]" (pp_help pp_a) h
(*
* Subcommand specifications
*)
module Subcommands = struct
type 'a t = { with_setup : bool; mname : string; context : 'a Term.t }
module T = struct
let args { with_setup; context; mname } =
Term.(
const (fun () config_file context_file dry_run output context ->
{ config_file; context_file; dry_run; output; context })
$ setup ~with_setup
$ config_file
$ context_file mname
$ dry_run
$ output
$ context)
end
(** The 'configure' subcommand *)
let configure t =
( Term.(
const (fun args depext extra_repo ->
Configure { args; depext; extra_repo })
$ T.args t
$ depext configuration_section
$ extra_repos configuration_section),
Cmd.info "configure" ~doc:"Configure a $(mname) application."
~man:
[
`S "DESCRIPTION";
`P
"The $(b,configure) command initializes a fresh $(mname) \
application.";
] )
let query t =
( Term.(
const (fun kind args depext extra_repo ->
Query { kind; args; depext; extra_repo })
$ kind
$ T.args t
$ depext query_section
$ extra_repos query_section),
Cmd.info "query" ~doc:"Query information about the $(mname) application."
~man:
[
`S "DESCRIPTION";
`P
"The $(b,query) command queries information about the $(mname) \
application.";
] )
(** The 'describe' subcommand *)
let describe t =
( Term.(
const (fun args eval dotcmd dot -> Describe { args; eval; dotcmd; dot })
$ T.args t
$ full_eval
$ dotcmd
$ dot),
Cmd.info "describe" ~doc:"Describe a $(mname) application."
~man:
[
`S "DESCRIPTION";
`P
"The $(b,describe) command describes the configuration of a \
$(mname) application.";
`P "The dot output contains the following elements:";
`Noblank;
`I
( "If vertices",
"Represented as circles. Branches are dotted, and the default \
branch is in bold." );
`Noblank;
`I
( "Configurables",
"Represented as rectangles. The order of the output arrows is \
the order of the functor arguments." );
`Noblank;
`I ("Data dependencies", "Represented as dashed arrows.");
`Noblank;
`I
( "App vertices",
"Represented as diamonds. The bold arrow is the functor part."
);
] )
(** The 'clean' subcommand *)
let clean t =
let doc = "Clean the files produced by $(mname) for a given application." in
( Term.(const (fun args -> Clean args) $ T.args t),
Cmd.info "clean" ~doc ~man:[ `S "DESCRIPTION"; `P doc ] )
(** The 'help' subcommand *)
let help t =
let topic =
let doc = Arg.info [] ~docv:"TOPIC" ~doc:"The topic to get help on." in
Arg.(value & pos 0 (some string) None & doc)
in
let help man_format cmds topic =
match topic with
| None -> `Help (man_format, None)
| Some topic -> (
let parser =
Arg.conv_parser
(Arg.enum (List.rev_map (fun s -> (s, s)) ("topics" :: cmds)))
in
match parser topic with
| Error (`Msg e) -> `Error (false, e)
| Ok t when t = "topics" ->
List.iter print_endline cmds;
`Ok ()
| Ok t -> `Help (man_format, Some t))
in
( Term.(
const (fun args _ _ _ () -> Help args)
$ T.args t
$ depext configuration_section
$ extra_repos configuration_section
$ full_eval
$ ret (const help $ Arg.man_format $ Term.choice_names $ topic)),
Cmd.info "help" ~doc:"Display help about $(mname) commands."
~man:
[
`S "DESCRIPTION";
`P "Prints help.";
`P "Use `$(mname) help topics' to get the full list of help topics.";
] )
let default ~with_setup ~name ~version =
let usage = `Help (`Plain, None) in
( Term.(ret (const usage) $ setup ~with_setup),
Cmd.info name ~version ~doc:"The $(mname) application builder"
~man:
[
`S "DESCRIPTION";
`P
"The $(mname) application builder. It glues together a set of \
libraries and configuration (e.g. network and storage) into a \
standalone unikernel or UNIX binary.";
`P
"Use $(mname) $(b,help <command>) for more information on a \
specific command.";
] )
end
(*
* Functions for extracting particular flags from the command line.
*)
let peek_full_eval argv =
match Cmd.eval_peek_opts ~argv full_eval with _, Ok (`Ok b) -> b | _ -> None
let peek_output argv =
match Cmd.eval_peek_opts ~argv output with _, Ok (`Ok b) -> b | _ -> None
let peek_args ?(with_setup = false) ~mname argv =
let args =
Subcommands.T.args { with_setup; mname; context = Term.const () }
in
match Cmd.eval_peek_opts ~argv args with
| _, Ok (`Ok b) | Some b, _ -> Some b
| _ -> None
let eval ?(with_setup = true) ?help_ppf ?err_ppf ~name ~version ~configure
~query ~describe ~clean ~help ~mname argv =
let default, info = Subcommands.default ~with_setup ~name ~version in
let args context = { Subcommands.with_setup; mname; context } in
let group =
Cmd.group ~default info
(List.map
(fun (term, info) -> Cmd.v info term)
[
Subcommands.configure (args configure);
Subcommands.describe (args describe);
Subcommands.query (args query);
Subcommands.clean (args clean);
Subcommands.help (args help);
])
in
match Cmd.eval_value ?help:help_ppf ?err:err_ppf ~argv ~catch:false group with
| Ok (#Cmd.eval_ok as v) -> v
| Error (#Cmd.eval_error as e) -> `Error e
let args = function
| Configure { args; _ } -> args
| Clean x | Help x -> x
| Query { args; _ } -> args
| Describe { args; _ } -> args
let choices =
[
("configure", `Configure);
("clean", `Clean);
("query", `Query);
("describe", `Describe);
("help", `Help);
]
let find_choices s =
List.find_all (fun (k, _) -> Astring.String.is_prefix ~affix:s k) choices
let find_kind s =
List.find_all (fun (k, _) -> Astring.String.is_prefix ~affix:s k) query_kinds
let next_pos_arg argv i =
let rec aux i =
if i >= Array.length argv then None
else if argv.(i) = "" then aux (i + 1)
else if argv.(i).[0] = '-' then aux (i + 1)
else Some i
in
aux i
let remove_argv argv i =
let a = Array.sub argv 0 i in
let b = Array.sub argv (i + 1) (Array.length argv - i - 1) in
Array.append a b
let rec find_next_kind argv i =
match next_pos_arg argv i with
| None -> (None, argv)
| Some i -> (
match find_kind argv.(i) with
| [] -> find_next_kind argv (i + 1)
| _ :: _ :: _ as cs ->
Fmt.invalid_arg "ambiguous sub-command: %a\n%!"
Fmt.Dump.(list string)
(List.map fst cs)
| [ (_, k) ] -> (Some k, remove_argv argv i))
let rec find_next_choice argv i =
match next_pos_arg argv i with
| None -> (None, argv)
| Some i -> (
match find_choices argv.(i) with
| [] -> find_next_choice argv (i + 1)
| _ :: _ :: _ as cs ->
Fmt.invalid_arg "ambiguous sub-command: %a\n%!"
Fmt.Dump.(list string)
(List.map fst cs)
| [ (_, a) ] -> (
match a with
| (`Configure | `Clean | `Describe | `Help) as c ->
(Some c, remove_argv argv i)
| `Query ->
let k, argv = find_next_kind argv (i + 1) in
(Some (`Query k), remove_argv argv i)))
let peek_choice argv =
try match find_next_choice argv 1 with Some c, _ -> `Ok c | _ -> `Default
with Invalid_argument _ -> `Error `Parse
type 'a result =
[ `Ok of 'a action
| `Error of 'a args option * [ `Exn | `Parse | `Term ]
| `Version ]
let peek ?(with_setup = false) ~mname argv : unit result =
let niet = Term.const () in
let peek t =
match Cmd.eval_peek_opts ~argv ~version_opt:true (fst t) with
| _, Ok `Version -> `Version
| _, Error e -> `Error (peek_args ~mname argv, e)
| _, Ok `Help -> (
let args = peek_args ~with_setup:false ~mname argv in
match args with
| Some args -> `Ok (Help args)
| _ -> `Error (None, `Parse))
| Some v, _ | _, Ok (`Ok v) -> `Ok v
in
let peek_cmd f =
let args = { Subcommands.with_setup; mname; context = niet } in
peek (f args)
in
match peek_choice argv with
| `Ok `Configure -> peek_cmd Subcommands.configure
| `Ok `Clean -> peek_cmd Subcommands.clean
| `Ok (`Query _) -> peek_cmd Subcommands.query
| `Ok `Describe -> peek_cmd Subcommands.describe
| `Ok `Help -> peek_cmd Subcommands.help
| `Default ->
peek (Subcommands.default ~with_setup ~name:"<name>" ~version:"<version>")
| `Error e -> `Error (peek_args ~mname argv, e)

144
unikernel/duniverse/mirage/lib/functoria/cli.mli Normal file
View file

@ -0,0 +1,144 @@
(*
* 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.
*)
(** Command-line handling. *)
open Cmdliner
type 'a args = {
context : 'a;
config_file : Fpath.t;
context_file : Fpath.t option;
output : string option;
dry_run : bool;
}
(** The type for global arguments. *)
val default_args : unit args
val peek_args :
?with_setup:bool -> mname:string -> string array -> unit args option
(** [peek_args ?with_setup argv] parses the global command-line arguments. If
[with_setup] is set (by default it is), interprets [-v] and [--color] to
set-up the terminal configuration as a side-effect. Returns None if global
command-line arguments are invalid. *)
val peek_output : string array -> string option
(** [peek_full_eval argv] reads the [--output] option from [argv]; the return
value is [None] if option is absent in [argv]. *)
val pp_args : 'a Fmt.t -> 'a args Fmt.t
(** [pp_args] is the pretty-printer for args. *)
(** {1 Sub-commands} *)
type 'a configure_args = {
args : 'a args;
depext : bool;
extra_repo : (string * string) list;
}
(** The type for arguments of the [configure] sub-command. *)
type 'a build_args = 'a args
(** The type for arguments of the [build] sub-command. *)
type 'a clean_args = 'a args
(** The type for arguments of the [clean] sub-command. *)
type 'a help_args = 'a args
(** The type for arguments of the [help] sub-command. *)
type query_kind =
[ `Name
| `Packages
| `Opam
| `Files
| `Dune of [ `Config | `Build | `Project | `Workspace | `Dist ]
| `Makefile ]
val pp_query_kind : query_kind Fmt.t
(** [pp_query_kind] is the pretty-printer for query kinds. *)
type 'a query_args = {
args : 'a args;
kind : query_kind;
depext : bool;
extra_repo : (string * string) list;
}
(** The type for arguments of the [query] sub-command. *)
type 'a describe_args = {
args : 'a args;
dotcmd : string;
dot : bool;
eval : bool option;
}
(** The type for arguments of the [describe] sub-command. *)
val peek_full_eval : string array -> bool option
(** [peek_full_eval argv] reads the [--eval] option from [argv]; the return
value is [None] if option is absent in [argv]. *)
(** A value of type [action] is the result of parsing command-line arguments
using [parse_args]. *)
type 'a action =
| Configure of 'a configure_args
| Query of 'a query_args
| Describe of 'a describe_args
| Clean of 'a clean_args
| Help of 'a help_args
val pp_action : 'a Fmt.t -> 'a action Fmt.t
(** [pp_action] is the pretty-printer for actions. *)
val args : 'a action -> 'a args
(** [args a] are [a]'s global arguments. *)
(** {1 Evaluation} *)
val eval :
?with_setup:bool ->
?help_ppf:Format.formatter ->
?err_ppf:Format.formatter ->
name:string ->
version:string ->
configure:'a Term.t ->
query:'a Term.t ->
describe:'a Term.t ->
clean:'a Term.t ->
help:'a Term.t ->
mname:string ->
string array ->
[ `Ok of 'a action | `Error of [ `Parse | `Term | `Exn ] | `Version | `Help ]
(** Parse the functoria command line. The arguments to [~configure],
[~describe], etc., describe extra command-line arguments that should be
accepted by the corresponding subcommands.
There are no side effects, save for the printing of usage messages and other
help when either the 'help' subcommand or no subcommand is specified. *)
type 'a result =
[ `Ok of 'a action
| `Error of 'a args option * [ `Exn | `Parse | `Term ]
| `Version ]
(** Similar to [Cmdliner.Term.result] but help is folded into [`Ok] and errors
also carry global command-line parameters. *)
val peek : ?with_setup:bool -> mname:string -> string array -> unit result
(** [peek] is the same as {!val:eval} but without failing on unknown arguments.
*)

50
unikernel/duniverse/mirage/lib/functoria/context.ml Normal file
View file

@ -0,0 +1,50 @@
(*
* 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.
*)
type 'a key = { name : string; put : 'a -> exn; get : exn -> 'a }
let new_key (type a) name =
let module M = struct
exception E of a
end in
let put a = M.E a in
let get = function
| M.E a -> a
| _ -> raise @@ Invalid_argument ("duplicate key: " ^ name)
in
{ name; put; get }
module Map = Map.Make (String)
type t = exn Map.t
let empty = Map.empty
let add k v (t : t) : t = Map.add k.name (k.put v) t
let mem k (t : t) = Map.mem k.name t
let find k (t : t) =
if Map.mem k.name t then Some (k.get @@ Map.find k.name t) else None
let dump : t Fmt.t =
let pp_elt ppf (k, v) = Fmt.pf ppf "[%s: %a]" k Fmt.exn v in
let map_iter f = Map.iter (fun k v -> f (k, v)) in
Fmt.box ~indent:2 @@ Fmt.(iter ~sep:(any "@ ")) map_iter pp_elt
let merge ~default m =
let aux _ _ v = Some v in
Map.union aux default m

49
unikernel/duniverse/mirage/lib/functoria/context.mli Normal file
View file

@ -0,0 +1,49 @@
(*
* 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.
*)
(** Universal map of keys *)
type 'a key
(** The type for keys. *)
val new_key : string -> 'a key
(** [new_key n] is a new key with name [k]. *)
type t
(** The type for context maps. *)
val empty : t
(** [empty] is the empty context. *)
val add : 'a key -> 'a -> t -> t
(** [add k v t] is [t] augmented with the binding [(k, v)]. Any previous binding
of [k] is removed. *)
val mem : 'a key -> t -> bool
(** [mem k t] is true iff [k] has been added to [t]. *)
val find : 'a key -> t -> 'a option
(** [find k t] is [v] is the binding [(k, v)] has been added to [t], otherwise
it is [None]. *)
val merge : default:t -> t -> t
(** [merge ~default t] merges [t] on top of [default]. If a key appears in both
[default] and [t], the value present in [t] is kept. *)
val dump : t Fmt.t
(** [dump] dumps the state of [t]. *)

82
unikernel/duniverse/mirage/lib/functoria/context_cache.ml Normal file
View file

@ -0,0 +1,82 @@
(*
* 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 Astring
open Action.Syntax
let src = Logs.Src.create "functoria.cache" ~doc:"functoria library"
module Log = (val Logs.src_log src : Logs.LOG)
type t = string array
let empty = [| "" |]
let is_empty t = t = empty
let write file argv =
Log.info (fun m ->
m "Preserving arguments in %a:@ %a" Fpath.pp file
Fmt.Dump.(array string)
argv);
(* Only keep args *)
let args = List.tl (Array.to_list argv) in
let args = List.map String.Ascii.escape args in
let args = String.concat ~sep:"\n" args ^ "\n" in
Action.write_file file args
let read file =
Log.info (fun l -> l "reading cache %a" Fpath.pp file);
let* is_file = Action.is_file file in
if not is_file then Action.ok empty
else
let* args = Action.read_file file in
let args = String.cuts ~sep:"\n" args in
(* remove trailing '\n' *)
let args = List.rev (List.tl (List.rev args)) in
(* Add an empty command *)
let args = "" :: args in
let args = Array.of_list args in
try
let args =
Array.map
(fun x ->
match String.Ascii.unescape x with
| Some s -> s
| None -> Fmt.failwith "%S: cannot parse" x)
args
in
Action.ok args
with Failure e -> Action.error e
let peek t term =
match Cmdliner.Cmd.eval_peek_opts ~argv:t term with
| Some c, _ | _, Ok (`Ok c) -> Some c
| _ -> None
let merge t term =
let cache = match peek t term with None -> Context.empty | Some c -> c in
let f term = Context.merge ~default:cache term in
Cmdliner.Term.(const f $ term)
let peek_output t = Cli.peek_output t
let file ~name args =
let build_dir = Fpath.parent args.Cli.config_file in
match args.Cli.context_file with
| Some f -> f
| None -> Fpath.(build_dir / name / "context")

53
unikernel/duniverse/mirage/lib/functoria/context_cache.mli Normal file
View file

@ -0,0 +1,53 @@
(*
* 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.
*)
(** Manage context caches, via the [--context-file <file>] command-line
argument. *)
type t
(** The type for cache. *)
val file : name:string -> 'a Cli.args -> Fpath.t
(** [file ~name args] is the filename of the context cache for the tool [name].
*)
val empty : t
(** The empty cache. *)
val is_empty : t -> bool
(** [is_empty t] is empty iff [t] is {!empty}. *)
val write : Fpath.t -> string array -> unit Action.t
(** [write f argv] writes the context cache in the file [f]. *)
val read : Fpath.t -> t Action.t
(** [read f] reads the context cache stored in [f]. The result is
[Action.ok empty] if [f] does not exists and [Action.error _] if the cache
contains garbage. *)
val peek : t -> Context.t Cmdliner.Term.t -> Context.t option
(** [peek t term] is the context obtained by evaluating [term] over the cached
context [t]. *)
val merge : t -> Context.t Cmdliner.Term.t -> Context.t Cmdliner.Term.t
(** [eval_context t term] is the context obtained by evaluating [term] over the
cached context [t]. *)
val peek_output : t -> string option
(** [peek_output t] is the evaluation of {!Cli.output} over the cached context
[t]. *)

202
unikernel/duniverse/mirage/lib/functoria/device.ml Normal file
View file

@ -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

169
unikernel/duniverse/mirage/lib/functoria/device.mli Normal file
View file

@ -0,0 +1,169 @@
(*
* 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.
*)
(** Signature for functoria devices. A [device] is a module implementation which
contains a runtime state which can be set either at configuration time (by
the application builder) or at runtime, using command-line arguments. *)
type ('a, 'b) t
(** The type for devices whose runtime state is of type ['a] and having extra
data-dependencies of type ['b]. *)
val module_type : ('a, 'b) t -> 'a Type.t
(** [module_type t] is [t]'s module type. *)
val module_name : ('a, 'b) t -> string
(** [module_name t] is [t]'s module name. *)
val packages : ('a, 'b) t -> Package.t list Key.value
(** [packages t] is the list of OPAM packages that are needed by [t].*)
val local_libs : ('a, 'b) t -> string list
(** [local_libs t] is the list of local libraries that are needed by [t]. *)
val install : ('a, 'b) t -> Info.t -> Install.t Key.value
(** [install t i] is the list of files installed by [t], using the build
information [i]. *)
val extra_deps : ('a, 'b) t -> 'b list
(** [extra_deps t] is the list of dependencies that be initialized before
running the code generated by [connect t]. *)
val id : ('a, 'b) t -> int
(** [id t] is [t]'s unique identifier. Freshly generated for each call to {!v}.
*)
val pp : 'b Fmt.t -> ('a, 'b) t Fmt.t
(** [pp pp_dep] is the pretty-printer for devices, using [pp_dep] to
pretty-print the extra data-dependencies. *)
val equal : ('a, 'b) t -> ('c, 'd) t -> bool
(** [equal] is the equality function for devices. *)
val witness : ('a, _) t -> ('b, _) t -> ('a, 'b) Typeid.witness
(** [witness a b] provides an equality witness. *)
val hash : ('a, 'b) t -> int
(** [hash t] is [t]'s hash. *)
(** {1 Resources} *)
val files : ('a, 'b) t -> Info.t -> Fpath.Set.t
(** [files t info s] is the list of files generated configure-time. *)
val keys : ('a, 'b) t -> Key.t list
(** [keys t] is the list of keys which can be used to configure [t]. *)
val runtime_args : ('a, 'b) t -> Runtime_arg.t list
(** [runtime_args t] is the list of command-line arguments which can be used to
configure [t] at runtime. *)
(** {1 Code Generation} *)
type 'a code = private {
pos : (string * int * int * int) option;
code : string;
}
(** The type for fragments of code of type ['a]. *)
val code :
pos:string * int * int * int ->
('a, Format.formatter, unit, 'b code) format4 ->
'a
(** Generate localised code. *)
val connect : ('a, 'b) t -> Info.t -> string -> string list -> 'a code
(** [connect t info impl_name args] is the code to execute in order to create a
new state (usually calling [<module_name t>.connect]) with the arguments
[args], in the context of the project information [info]. The freshly
created state will be made available in [var_name t] *)
val start : ?pos:string * int * int * int -> string -> string list -> 'a code
(** [start ?pos impl_name args] is the code [<impl_name>.start <args>]. *)
val nice_name : _ t -> string
(** [nice_name d] provides a identifier unique to [d] which is a valid OCaml
identifier. *)
(** {1 Actions} *)
val dune : ('a, 'b) t -> Info.t -> Dune.stanza list
(** [dune t info] are the dune stanza which needs to be generated to build the
application. *)
(** {1 Configuration} *)
val configure : ('a, 'b) t -> Info.t -> unit Action.t
(** [configure t info] is configure hook for [t] the device and the files it
generates. During the configure phase, you cannot rely on [packages t] being
installed.
To run code during the [build] phase, generate a [dune] fragment instead. *)
(** {1 Constructors} *)
val v :
?packages:Package.t list ->
?packages_v:Package.t list Key.value ->
?local_libs:string list ->
?install:(Info.t -> Install.t) ->
?install_v:(Info.t -> Install.t Key.value) ->
?keys:Key.t list ->
?runtime_args:Runtime_arg.t list ->
?extra_deps:'b list ->
?connect:(Info.t -> string -> string list -> 'a code) ->
?dune:(Info.t -> Dune.stanza list) ->
?configure:(Info.t -> unit Action.t) ->
?files:(Info.t -> Fpath.t list) ->
string ->
'a Type.t ->
('a, 'b) t
val extend :
?packages:Package.t list ->
?packages_v:Package.t list Key.value ->
?dune:(Info.t -> Dune.stanza list) ->
?pre_configure:(Info.t -> unit Action.t) ->
?post_configure:(Info.t -> unit Action.t) ->
?files:(Info.t -> Fpath.t list) ->
('a, 'b) t ->
('a, 'b) t
(** {1 Device graphs} *)
module Graph : sig
type ('a, 'i) device
(** A graph of devices, annotated with their arguments, dependencies, and a
unique identifier.
Warning: this is truly a DAG: sharing {b must} be preserved. Manual walks
are discouraged, please use {!fold} instead. *)
type t =
| D : { dev : (_, _) device; args : t list; deps : t list; id : int } -> t
val fold : (t -> 'a -> 'a) -> t -> 'a -> 'a
(** [fold f g z] applies [f] on each device in topological order. *)
val var_name : t -> string
(** [var_name t] returns the name identifying [t] which is a valid OCaml
variable identifier. *)
val impl_name : t -> string
(** [impl_name t] returns the name identifying [t]'s module implementation. *)
end
with type ('a, 'i) device := ('a, 'i) t

19
unikernel/duniverse/mirage/lib/functoria/dune Normal file
View file

@ -0,0 +1,19 @@
(include_subdirs no)
(library
(name functoria)
(public_name mirage.functoria)
(libraries
uri
emile
unix
cmdliner
rresult
fmt
astring
fpath
bos
fmt.cli
logs.fmt
fmt.tty
logs.cli))

107
unikernel/duniverse/mirage/lib/functoria/dune.ml Normal file
View file

@ -0,0 +1,107 @@
(*
* 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 Astring
type stanza = string option
type t = string list
let stanza v = Some (String.trim v)
let stanzaf fmt = Fmt.kstr stanza fmt
let v x : t =
List.fold_left
(fun acc -> function None -> acc | Some f -> f :: acc)
[] (List.rev x)
let pp_list pp = Fmt.(list ~sep:(any "\n\n") pp)
let pp ppf (t : t) = Fmt.pf ppf "%a" (pp_list Fmt.string) t
let to_string t = Fmt.to_to_string pp t ^ "\n"
(* emulate the dune compact form for lists *)
let compact_list ?(indent = 2) field ppf l =
let all = Buffer.create 1024 in
let line = Buffer.create 70 in
let sep = "\n" ^ String.v ~len:indent (fun _ -> ' ') in
let first_char = ref true in
let first_line = ref true in
let flush () =
Buffer.add_buffer all line;
Buffer.clear line;
Buffer.add_string line sep;
first_line := false
in
List.iter
(fun w ->
let max = if !first_line then 75 - indent - String.length field else 75 in
let wn = String.length w in
if wn >= 40 || Buffer.length line + wn >= max then flush ();
if not !first_char then Buffer.add_char line ' ';
first_char := false;
Buffer.add_string line w)
l;
flush ();
Fmt.pf ppf "%s" (Buffer.contents all)
let config_rule ~config_ml_file ~packages =
let pkgs =
match packages with
| [] -> ""
| pkgs ->
let pkgs =
List.fold_left
(fun acc pkg ->
let pkgs = String.Set.of_list (Package.libraries pkg) in
String.Set.union pkgs acc)
String.Set.empty pkgs
|> String.Set.elements
in
String.concat ~sep:" " pkgs
in
let rename_config_file =
let config_ml_file = Fpath.base config_ml_file in
let ext = Fpath.get_ext config_ml_file in
let name = Fpath.rem_ext config_ml_file |> Fpath.to_string in
if name = "config" then []
else
[
stanzaf "(rule (copy# %s config%s))"
(Fpath.to_string config_ml_file)
ext;
]
in
let contents =
stanzaf
{|
(executable
(name config)
(modules config)
(flags :standard -warn-error -A)
(libraries %s))
|}
pkgs
in
v (rename_config_file @ [ contents ])
let base ~packages ~config_ml_file =
let dune_base = config_rule ~config_ml_file ~packages in
let disable_conflicting_directories = "(data_only_dirs duniverse dist)" in
disable_conflicting_directories :: dune_base
let base_project = [ stanza "(lang dune 2.9)" ]
let base_workspace = v [ stanza "(lang dune 2.9)\n(context default)" ]

40
unikernel/duniverse/mirage/lib/functoria/dune.mli Normal file
View file

@ -0,0 +1,40 @@
(*
* 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.
*)
(** Dune files. *)
type stanza
val stanza : string -> stanza
val stanzaf : ('a, Format.formatter, unit, stanza) format4 -> 'a
type t
val v : stanza list -> t
val pp : t Fmt.t
val to_string : t -> string
val compact_list : ?indent:int -> string -> string list Fmt.t
val base : packages:Package.t list -> config_ml_file:Fpath.t -> t
(** [base] is a minimal [dune] file able to build [config.ml] *)
val base_project : stanza list
(** the minimal [dune-project] to compile [config.ml]. *)
val base_workspace : t
(** the minimal [dune-workspace] to compile [config.ml]. *)

245
unikernel/duniverse/mirage/lib/functoria/engine.ml Normal file
View file

@ -0,0 +1,245 @@
(*
* 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 Astring
open Action.Syntax
type t = Device.Graph.t
let if_keys x =
Impl.collect
(module Key.Set)
(function If cond -> Key.deps cond | App | Dev _ -> Key.Set.empty)
x
module Keys = struct
type t = Key.Set.t
let union a b = Key.Set.union a b
let empty = Key.Set.empty
end
let keys x =
Impl.collect
(module Keys)
(function
| Dev c -> Key.Set.of_list (Device.keys c)
| If cond -> Key.deps cond
| App -> Keys.empty)
x
module Runtime_args = struct
type t = Runtime_arg.Set.t
let union a b = Runtime_arg.Set.union a b
let empty = Runtime_arg.Set.empty
end
let runtime_args x =
Impl.collect
(module Runtime_args)
(function
| Dev c -> Runtime_arg.Set.of_list (Device.runtime_args c)
| If _ -> Runtime_args.empty
| App -> Runtime_args.empty)
x
module Packages = struct
type t = Package.Set.t Key.value
let union x y = Key.(pure Package.Set.union $ x $ y)
let empty = Key.pure Package.Set.empty
end
let packages t =
let open Impl in
let aux = function
| Dev c ->
let pkgs = Device.packages c in
let runtime_args = Device.runtime_args c in
let extra_pkgs =
List.fold_left
(fun acc k ->
let pkgs = Runtime_arg.packages k in
Package.Set.(union acc (of_list pkgs)))
Package.Set.empty runtime_args
in
let aux x = Package.Set.(union (of_list x) extra_pkgs) in
Key.(pure aux $ pkgs)
| If _ | App -> Packages.empty
in
let return x = Package.Set.to_list x in
Key.(pure return $ Impl.collect (module Packages) aux t)
module Installs = struct
type t = Install.t Key.value
let union x y = Key.(pure Install.union $ x $ y)
let empty = Key.pure Install.empty
end
let install i x =
Impl.collect
(module Installs)
(function Dev c -> Device.install c i | If _ | App -> Installs.empty)
x
let files info t =
Impl.collect
(module Fpath.Set)
(function Dev c -> Device.files c info | If _ | App -> Fpath.Set.empty)
t
module Dune = struct
type t = Dune.stanza list
let union = ( @ )
let empty = []
end
let dune info =
Impl.collect (module Dune) @@ function
| Dev c -> Device.dune c info
| If _ | App -> Dune.empty
(* [module_expresion tbl c args] returns the module expression of
the functor [c] applies to [args]. *)
let module_expression fmt (c, args) =
Fmt.pf fmt "%s%a" (Device.module_name c)
Fmt.(
list ~sep:(any "")
(any "(" ++ of_to_string Device.Graph.impl_name ++ any ")"))
args
let find_all_devices info g i =
let ctx = Info.context info in
let id = Impl.with_left_most_device ctx i { f = Device.id } in
let f x l =
let (Device.Graph.D { dev; _ }) = x in
if Device.id dev = id then x :: l else l
in
Device.Graph.fold f g []
let iter_actions f t =
let f v res =
let* () = res in
f v
in
Device.Graph.fold f t (Action.ok ())
let lines_of_str str =
String.fold_left (fun n -> function '\n' -> n + 1 | _ -> n) 0 str
type main = { dir : Fpath.t; path : Fpath.t; mutable lines : int }
let main info =
let path = Info.main info in
let dir = Fpath.(Info.(parent (config_file info) / project_name info)) in
let+ str = Action.read_file path in
let lines = lines_of_str str in
{ dir; path; lines }
let append_main main msg fmt =
let purpose = Fmt.str "Append to main.ml (%s)" msg in
Fmt.kstr
(fun str ->
main.lines <- main.lines + lines_of_str str + 1;
Action.with_output ~path:main.path ~append:true ~purpose (fun ppf ->
Fmt.pf ppf "%s@." str))
fmt
let pp_pos ppf = function
| None -> ()
| Some (file, line, _, _) -> Fmt.pf ppf "# %d %S@." line file
let reset_pos { dir; path; lines } =
(* lines are 1-based and the line directive is refering to
"next line will be Y", so if we put a directive in the first line of a
file, it needs to say "# 2 myfile.ml" since the next line will be the
second one. This is the reason for the 2 below. *)
let file = Fpath.(dir // path) |> Fpath.normalize |> Fpath.to_string in
Some (file, lines + 2, 0, 0)
let configure info t =
let f (v : t) =
let* main = main info in
let (D { dev; args; _ }) = v in
let* () = Device.configure dev info in
if args = [] then Action.ok ()
else
let* () = append_main main "reset" "%a" pp_pos (reset_pos main) in
append_main main "configure" "module %s = %a\n" (Device.Graph.impl_name v)
module_expression (dev, args)
in
iter_actions f t
let meta_init fmt (connect_name, result_name) =
Fmt.pf fmt " let _%s = Lazy.force %s in@ " result_name connect_name
let emit_connect fmt (iname, names, runtime_args, connect_code) =
(* We avoid potential collision between double application
by prefixing with "_". This also avoid warnings. *)
let rnames = List.map (fun x -> "_" ^ x) names in
let knames = List.map (fun k -> "_" ^ Runtime_arg.var_name k) runtime_args in
let bind ppf name = Fmt.pf ppf " _%s >>= fun %s ->\n" name name in
let bind_key ppf k =
Fmt.pf ppf " let _%s = %a in\n" (Runtime_arg.var_name k) Runtime_arg.call k
in
let { Device.pos; code } = connect_code (rnames @ knames) in
Fmt.pf fmt "let %s = lazy (\n%a%a%a%a %s@\n);;" iname
Fmt.(list ~sep:nop meta_init)
(List.combine names rnames)
Fmt.(list ~sep:nop bind)
rnames
Fmt.(list ~sep:nop bind_key)
runtime_args pp_pos pos code
let emit_run main init main_name =
(* "exit 1" is ok in this code, since cmdliner will print help. *)
let force ppf name = Fmt.pf ppf "Lazy.force %s >>= fun _ ->\n " name in
append_main main "emit_run"
"let () =\n let t = %aLazy.force %s in\n run t\n;;"
Fmt.(list ~sep:nop force)
init main_name
let connect ?(init = []) info t =
let* main = main info in
let f (v : t) =
let (D { dev; args; deps; _ }) = v in
let var_name = Device.Graph.var_name v in
let impl_name = Device.Graph.impl_name v in
let arg_names = List.map Device.Graph.var_name (args @ deps) in
let runtime_args = Device.runtime_args dev in
let* () =
append_main main "connect" "%a" emit_connect
(var_name, arg_names, runtime_args, Device.connect dev info impl_name)
in
append_main main "reset" "%a" pp_pos (reset_pos main)
in
let* () = iter_actions f t in
let main_name = Device.Graph.var_name t in
let init_names =
List.fold_left
(fun acc i ->
match find_all_devices info t i with
| [] -> assert false
| ds -> List.map Device.Graph.var_name ds @ acc)
[] init
|> List.rev
in
emit_run main init_names main_name

56
unikernel/duniverse/mirage/lib/functoria/engine.mli Normal file
View file

@ -0,0 +1,56 @@
(*
* 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.
*)
(** Functoria engine. *)
val if_keys : Impl.abstract -> Key.Set.t
(** [if_keys t] is the set of [if] keys in the graph [t]. *)
val keys : Impl.abstract -> Key.Set.t
(** [keys t] is the set of keys in the graph [t]. *)
val runtime_args : Impl.abstract -> Runtime_arg.Set.t
(** [runtime_args t] is the set of runtime arguments in the graph [t]. *)
val packages : Impl.abstract -> Package.t list Key.value
(** [packages t] is the set of packages in the graph [t]. *)
val install : Info.t -> Impl.abstract -> Install.t Key.value
(** [install i t] is the set of files installed by the graph [t]. *)
val files : Info.t -> Impl.abstract -> Fpath.Set.t
(** [files i t] is the list of files generated configure-time. *)
val dune : Info.t -> Impl.abstract -> Dune.stanza list
(** [dune i t] is the list of dune stanzas needed to build the project [t] with
the build information [i]. *)
(** {2 Triggering Hooks} *)
type t = Device.Graph.t
(** The type for key graphs. *)
val configure : Info.t -> t -> unit Action.t
(** [configure i t] calls all the configuration hooks for each of the
implementations appearing in [t], in topological order. Use the build
information [i]. *)
val connect : ?init:'a Impl.t list -> Info.t -> t -> unit Action.t
(** [connect ?init i t] generates the [connect] functions in [main.ml], for each
of the implementations appearing [t], in topological order. Use build
information [i]. *)

91
unikernel/duniverse/mirage/lib/functoria/filegen.ml Normal file
View file

@ -0,0 +1,91 @@
(*
* 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 Astring
open Action.Syntax
module type PROJECT = sig
val name : string
val version : string
end
module Make (P : PROJECT) = struct
let lang path =
let base, ext = Fpath.split_ext path in
let base = Fpath.basename base in
match (base, ext) with
| _, (".ml" | ".mli") -> Some `OCaml
| _, (".opam" | ".install") -> Some `Opam
| "Makefile", _ -> Some `Make
| ("dune" | "dune-project" | "dune-workspace"), _ -> Some `Sexp
| _ -> None
let headers lang =
let line = Fmt.str "Generated by %s.%s" P.name P.version in
match lang with
| `Sexp -> Fmt.str ";; %s" line
| `Opam | `Make -> Fmt.str "# %s" line
| `OCaml -> Fmt.str "(* %s *)" line
let short_headers lang =
match lang with
| `Sexp -> Fmt.str ";; Generated by"
| `Opam | `Make -> "# Generated by"
| `OCaml -> "(* Generated by"
let has_headers file contents =
match Fpath.basename file with
| "dune-project" | "dune-workspace" -> (
let lines = String.cuts ~sep:"\n" ~empty:true (String.trim contents) in
match List.rev lines with
| x :: _ -> String.is_infix ~affix:(short_headers `Sexp) x
| _ -> false)
| _ -> (
match lang file with
| None -> false
| Some lang ->
let affix = short_headers lang in
String.is_infix ~affix contents)
let can_overwrite file =
let* is_file = Action.is_file file in
if is_file then
let+ content = Action.read_file file in
has_headers file content
else Action.ok true
let rm file =
let* can_overwrite = can_overwrite file in
if not can_overwrite then Action.ok () else Action.rm file
let with_headers file contents =
if has_headers file contents then contents
else
match Fpath.basename file with
| "dune-project" | "dune-workspace" | "dune-workspace.config" ->
Fmt.str "%s\n%s\n" contents (headers `Sexp)
| _ -> (
match lang file with
| None -> Fmt.invalid_arg "%a: invalide lang" Fpath.pp file
| Some lang -> Fmt.str "%s\n\n%s" (headers lang) contents)
let write file contents =
let* can_overwrite = can_overwrite file in
if not can_overwrite then Action.ok ()
else Action.write_file file (with_headers file contents)
end

30
unikernel/duniverse/mirage/lib/functoria/filegen.mli Normal file
View file

@ -0,0 +1,30 @@
(*
* 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.
*)
(** Basic helpers to generate files. *)
module type PROJECT = sig
val name : string
val version : string
end
module Make (_ : PROJECT) : sig
val write : Fpath.t -> string -> unit Action.t
val headers : [ `OCaml | `Sexp | `Make | `Opam ] -> string
val rm : Fpath.t -> unit Action.t
end

58
unikernel/duniverse/mirage/lib/functoria/functoria.ml Normal file
View file

@ -0,0 +1,58 @@
(*
* 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.
*)
module Context = Context
module Key = Key
module Runtime_arg = Runtime_arg
module Package = Package
module Info = Info
module Type = Type
module Impl = Impl
module Device = Device
module Install = Install
module Opam = Opam
module Lib = Lib
module Tool = Tool
module Engine = Engine
module DSL = DSL
module Cli = Cli
module Action = Action
module Dune = Dune
module type DSL = module type of DSL
module type KEY =
module type of Key
with type 'a Arg.t = 'a Key.Arg.t
and type 'a value = 'a Key.value
and type 'a key = 'a Key.key
and type t = Key.t
and type Set.t = Key.Set.t
(** Devices *)
include DSL
let job = Job.t
let noop = Job.noop
let runtime_args = Job.runtime_args
type argv = Argv.t
let sys_argv = Argv.sys_argv
let argv = Argv.argv

168
unikernel/duniverse/mirage/lib/functoria/functoria.mli Normal file
View file

@ -0,0 +1,168 @@
(*
* 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.
*)
(** {1 The Functoria DSL} *)
(** Functoria is a DSL to describe a set of modules and functors, their types
and how to apply them in order to produce a complete application.
The main use case is mirage. See the [Mirage] documentation for details.
Functoria is a DSL to write configuration files for functor-heavy
applications. Such configuration files (imaginatively called [config.ml])
usually contains three parts: one for defining toplevel modules, one for
defining configuration kyes and one for defining applications using these
modules and keys.
{2 Defining toplevel modules}
To define toplevel modules, use the {!main} function. Among its various
arguments, it takes the module name and its signature. The type is assembled
with the {!Type} combinators, like the [@->] operator, which represents a
functor arrow.
{[
let main = main "Unikernel.Main" (m @-> job)
]}
This declares that the functor [Unikernel.Main] takes a module of type [m]
and returns a module of type {!module-DSL.job}. [job] has a specific meaning
for functoria: it is a module which defines at least a function [start],
which should have one argument per functor argument and should return
[unit].
It is up to the user to ensure that the declaration matches the
implementation, or be rewarded by a compiler error later on. If the
declaration is correct, everything that follows will be.
{2 Defining configuration keys}
A configuration key is composed of:
- {i name} : The name of the value in the program.
- {i description} : How it should be displayed/serialized.
- {i stage} : Is the key available only at runtime, at configure time or
both?
- {i documentation} : It is not optional so you should really write it.
Consider a multilingual application: we want to pass the default language as
a parameter. We will use a simple string, so we can use the predefined
description {!Key.Arg.string}. We want to be able to define it both at
configure and run time, so we use the stage [Both]. This gives us the
following code:
{[
let lang_key =
let doc =
Key.Arg.info ~doc:"The default language for the application."
[ "l"; "lang" ]
in
Key.create "language" @@ Key.Arg.(opt ~stage:`Both string "en" doc)
]}
Here, we defined both a long option ["--lang"] and a short one ["-l"] (the
format is similar to the one used by
{{:http://erratique.ch/software/cmdliner} Cmdliner}. In the application
code, the value is retrieved with [Key_gen.language ()].
The option is also documented in the ["--help"] option for both the
[configure] subcommand (at configure time) and [./app.exe] (at startup
time).
{v
-l VAL, --lang=VAL (absent=en) The default language for the application.
v}
{2 Defining applications}
To register a new application, use [register]:
{[
let () = register "app" [ main $ impl ]
]}
This function (which should only be called once) takes as argument the name
of the application and a list of jobs. The jobs are defined using the
{!Impl} DSL; for instance the operator [$] is used to apply the functor
[main] (aka [Unikernel.Main]) to the default console.
Once an application is registered, it can be configured and built using
command-line arguments.
Configuration keys we can use be used to switch implementation at configure
time. This is done by using the {!Key} DSL, for instance to check whether
[lang_key] is instanciated with a given string:
{[
let lang_is "s" = Key.(pure (( = ) s) $ value lang_key)
]}
Then by using the {!if_impl} combinator to choose between two
implementations depending on the value of the key:
{[
let impl = if_impl (is "fi") finnish_impl not_finnish_implementation
]} *)
module type DSL = module type of DSL
include DSL
module Package = Package
module Info = Info
module Install = Install
module Device = Device
(** {1 Useful module implementations} *)
val job : job typ
(** [job] is the signature for user's application main module. *)
val noop : job impl
(** [noop] is an implementation of {!type-job} that holds no state, does nothing
and has no dependency. *)
type argv = Argv.t
(** The type for command-line arguments, similar to the usual [Sys.argv]. *)
val argv : argv typ
(** [argv] is a value representing {!type-argv} module types. *)
val sys_argv : argv impl
(** [sys_argv] is a device providing command-line arguments by using [Sys.argv].
*)
val runtime_args :
?runtime_package:package -> ?runtime_modname:string -> argv impl -> job impl
(** [runtime_args a] is an implementation of {!type-job} that holds the parsed
command-line arguments. By default [runtime_package] is
["mirage-runtime.functoria"] and [runtime_modname] is ["Functoria_runtime"].
*)
module Type = Type
module Impl = Impl
module Context = Context
module Key = Key
module Runtime_arg = Runtime_arg
module Opam = Opam
module Lib = Lib
module Tool = Tool
module Engine = Engine
module DSL = DSL
module Cli = Cli
module Action = Action
module Dune = Dune

464
unikernel/duniverse/mirage/lib/functoria/impl.ml Normal file
View file

@ -0,0 +1,464 @@
(*
* 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.
*)
let src = Logs.Src.create "functoria" ~doc:"functoria library"
module Log = (val Logs.src_log src : Logs.LOG)
type 'a t =
| If : {
cond : 't Key.value;
branches : ('t * 'a t) list;
default : 'a t;
}
-> 'a t
| Dev : { dev : 'a device; args : ('a, 'v) tl; deps : abstract list } -> 'v t
| App : { f : 'a t; args : ('a, 'v) tl } -> 'v t
and abstract = Abstract : _ t -> abstract
and ('a, 'b) tl =
| Nil : ('a, 'a) tl
| Cons : 'a t * ('b, 'c) tl -> ('a -> 'b, 'c) tl
and 'a device = ('a, abstract) Device.t
(** Constructors *)
let abstract t = Abstract t
let rec app_has_no_arguments : type a. a t -> bool = function
| App { f = _; args = Cons _ } -> false
| App { f; args = Nil } -> app_has_no_arguments f
| Dev { args = Nil; deps = []; dev } ->
(* special hack for Job.noop *)
if not (String.equal (Device.module_name dev) "Unit") then
match Device.runtime_args dev with [] -> true | _ -> false
else false
| Dev _ -> false
| If { cond = _; branches; default } ->
app_has_no_arguments default
|| List.exists (fun (_, branch) -> app_has_no_arguments branch) branches
(* Devices *)
let mk_dev ~args ~deps dev = Dev { dev; args; deps }
let of_device dev = mk_dev ~args:Nil ~deps:(Device.extra_deps dev) dev
let local_libs = function Dev { dev; _ } -> Device.local_libs dev | _ -> []
let v ?packages ?packages_v ?runtime_args ?keys ?extra_deps ?connect ?dune
?configure ?files module_name module_type =
of_device
@@ Device.v ?packages ?packages_v ?runtime_args ?keys ?extra_deps ?connect
?dune ?configure ?files module_name module_type
let main ?pos ?packages ?packages_v ?runtime_args ?keys ?extra_deps module_name
ty =
let connect _ = Device.start ?pos in
v ?packages ?packages_v ?runtime_args ?keys ?extra_deps ~connect module_name
ty
(* If *)
let mk_switch ~cond ~branches ~default = If { cond; branches; default }
let if_ cond then_ else_ =
mk_switch ~cond ~branches:[ (true, then_); (false, else_) ] ~default:then_
let match_ cond ~default branches = mk_switch ~cond ~branches ~default
(* App *)
let rec concat_tl : type a b c. (a, b) tl -> (b, c) tl -> (a, c) tl =
fun t1 t2 -> match t1 with Nil -> t2 | Cons (h, t) -> Cons (h, concat_tl t t2)
let rec mk_app : type a v. f:a t -> args:(a, v) tl -> v t =
fun ~f ~args:args1 ->
match f with
| Dev { dev; args = args2; deps } ->
mk_dev ~args:(concat_tl args2 args1) ~deps dev
| App { f; args = args2 } -> mk_app ~f ~args:(concat_tl args2 args1)
| _ -> App { f; args = args1 }
let ( $ ) f x = mk_app ~f ~args:(Cons (x, Nil))
(** Utilities *)
let rec pp : type a. a t Fmt.t =
fun ppf -> function
| Dev { dev; args; deps = _ } ->
Fmt.pf ppf "@[<v>@[Dev %a@]@,@[<v2>args=[%a]@]@]" (Device.pp pp_abstract)
dev pp_tl args
| App { f; args } -> Fmt.pf ppf "App %a(%a)" pp f pp_tl args
| If { cond = _; branches; default } ->
Fmt.pf ppf "Switch (_,%a,%a)" (Fmt.list pp) (List.map snd branches) pp
default
and pp_tl : type a b. (a, b) tl Fmt.t =
fun ppf -> function
| Nil -> ()
| Cons (h, t) -> Fmt.pf ppf "%a,@ %a" pp h pp_tl t
and pp_abstract ppf (Abstract i) = pp ppf i
(** Tables and traversals *)
(* **** WARNING ******
The [impl] type forms a DAG, implemented as terms with sharing.
It is *essential* to preserve sharing while walking the terms.
Otherwise
- We risk double initialization of devices
- The DOT graph is a mess
- We might collect information twice
As such, the equality, hashing, and tables must be tuned to share
[impl]s appropriately and the various traversals must use appropriate tables.
*)
let rec hash : type a. a t -> int = function
| Dev { dev; args; deps } ->
Hashtbl.hash
(`Dev, Device.hash dev, hash_tl args, List.map hash_abstract deps)
| App { f; args } -> Hashtbl.hash (`App, hash f, hash_tl args)
| If { cond; branches; default } ->
Hashtbl.hash
( `If,
cond,
List.map (fun (p, t) -> Hashtbl.hash (p, hash t)) branches,
hash default )
and hash_abstract (Abstract x) = hash x
and hash_tl : type a v. (a, v) tl -> int =
fun x ->
match x with
| Nil -> Hashtbl.hash `Nil
| Cons (h, t) -> Hashtbl.hash (`Cons, hash h, hash_tl t)
type ex = Ex : 'a -> ex
let equal_list p l1 l2 =
List.length l1 = List.length l2 && List.for_all2 p l1 l2
let rec equal : type t1 t2. t1 t -> t2 t -> (t1, t2) Typeid.witness =
fun x y ->
match (x, y) with
| Dev c, Dev c' -> (
match
( equal_list equal_abstract c.deps c'.deps,
equal_tl c.args c'.args (Device.witness c.dev c'.dev) )
with
| true, Eq -> Eq
| _ -> NotEq)
| App a, App b -> (
match equal_tl a.args b.args (equal a.f b.f) with
| Eq -> Eq
| NotEq -> NotEq)
| If x1, If x2 -> (
match
( equal x1.default x2.default,
Obj.repr x1.cond == Obj.repr x2.cond,
equal_list
(fun (p1, t1) (p2, t2) ->
Ex p1 = Ex p2 && equal_abstract (abstract t1) (abstract t2))
x1.branches x2.branches )
with
| Eq, true, true -> Eq
| _ -> NotEq)
| _ -> NotEq
and equal_abstract (Abstract x) (Abstract y) = Typeid.to_bool @@ equal x y
and equal_tl : type t1 t2 v1 v2.
(t1, v1) tl ->
(t2, v2) tl ->
(t1, t2) Typeid.witness ->
(v1, v2) Typeid.witness =
fun x y eq ->
match (x, y, eq) with
| Nil, Nil, Eq -> Eq
| Cons (h1, t1), Cons (h2, t2), Eq -> (
match (equal h1 h2, equal_tl t1 t2 Eq) with Eq, Eq -> Eq | _ -> NotEq)
| _ -> NotEq
module Tbl = Hashtbl.Make (struct
type t = abstract
let hash = hash_abstract
let equal = equal_abstract
end)
module Hashcons : sig
type tbl
val create : unit -> tbl
val add : tbl -> 'a t -> 'a t -> unit
val get : tbl -> 'a t -> 'a t option
end = struct
type tbl = abstract Tbl.t
let create () = Tbl.create 50
let add tbl a b = Tbl.add tbl (abstract a) (abstract b)
let get (type a) tbl (oldv : a t) : a t option =
if Tbl.mem tbl @@ abstract oldv then
let (Abstract newv) = Tbl.find tbl (abstract oldv) in
match equal oldv newv with Eq -> Some newv | NotEq -> None
else None
end
let simplify ~full ~context (Abstract t) =
let tbl = Hashcons.create () in
let rec aux : type a. a t -> a t =
fun impl ->
match Hashcons.get tbl impl with
| Some impl' -> impl'
| None ->
let acc =
match impl with
| If { cond; branches; default } ->
(* Either
- A key is present in the context
- We are in full mode, and we use its default value
*)
if full || Key.mem context cond then
let path = Key.eval context cond in
let t =
try List.assoc path branches with Not_found -> default
in
aux t
else
let branches = List.map (fun (p, t) -> (p, aux t)) branches in
mk_switch ~cond ~branches ~default
| Dev { dev; args; deps } ->
let args = aux_tl args in
let deps = List.map aux_abstract deps in
mk_dev ~args ~deps dev
| App { f; args } ->
let f = aux f in
let args = aux_tl args in
mk_app ~f ~args
in
Hashcons.add tbl impl acc;
acc
and aux_abstract (Abstract a) = Abstract (aux a)
and aux_tl : type a v. (a, v) tl -> (a, v) tl = function
| Nil -> Nil
| Cons (h, t) -> Cons (aux h, aux_tl t)
in
Abstract (aux t)
let eval ~context (Abstract t) =
let new_id =
let r = ref 0 in
fun () ->
incr r;
!r
in
let tbl = Tbl.create 50 in
let rec aux : type a. a t -> Device.Graph.t =
fun impl ->
if Tbl.mem tbl @@ abstract impl then Tbl.find tbl (abstract impl)
else
let acc =
match impl with
| Dev { dev; args; deps } ->
let args = aux_tl args in
let deps = List.map aux_abstract deps in
Device.Graph.D { dev; args; deps; id = new_id () }
| App { f; args = extra_args } ->
let (D { dev; args; deps; id = _ }) = aux f in
let extra_args = aux_tl extra_args in
D { dev; args = args @ extra_args; deps; id = new_id () }
| If { cond; branches; default } ->
let path = Key.eval context cond in
let t = try List.assoc path branches with Not_found -> default in
aux t
in
Tbl.add tbl (abstract impl) acc;
acc
and aux_abstract (Abstract a) = aux a
and aux_tl : type a v. (a, v) tl -> _ = function
| Nil -> []
| Cons (h, t) ->
let a = aux h in
a :: aux_tl t
in
aux t
type 'b f_dev = { f : 'a. ('a, abstract) Device.t -> 'b }
let with_left_most_device ctx t (f : _ f_dev) =
let rec aux : type a. a t -> _ = function
| Dev d -> f.f d.dev
| App a -> aux a.f
| If { cond; branches; default } ->
let path = Key.eval ctx cond in
let t = try List.assoc path branches with Not_found -> default in
aux t
in
aux t
type 'b f_dev_full = {
f : 'a 'v. args:'b list -> deps:'b list -> 'a device -> 'b;
}
type 'a f_switch = {
if_ : 'r. cond:'r Key.value -> branches:('r * 'a) list -> default:'a -> 'a;
}
type 'a f_app = f:'a -> args:'a list -> 'a
let map (type r) ~(mk_switch : _ f_switch) ~(mk_app : _ f_app)
~(mk_dev : _ f_dev_full) t =
let tbl = Tbl.create 50 in
let rec aux : type a. a t -> r =
fun impl ->
if Tbl.mem tbl @@ abstract impl then Tbl.find tbl (abstract impl)
else
let acc =
match impl with
| Dev { dev; args; deps } ->
let deps =
List.fold_right (fun (Abstract x) l -> aux x :: l) deps []
in
let args = aux_tl args in
mk_dev.f ~args ~deps dev
| App { f; args } ->
let f = aux f in
let args = aux_tl args in
mk_app ~f ~args
| If { cond; branches; default } ->
let branches = List.map (fun (p, t) -> (p, aux t)) branches in
let default = aux default in
mk_switch.if_ ~cond ~branches ~default
in
Tbl.add tbl (abstract impl) acc;
acc
and aux_tl : type a v. (a, v) tl -> r list = function
| Nil -> []
| Cons (h, t) -> aux h :: aux_tl t
in
aux t
type label = If : _ Key.value -> label | Dev : _ Device.t -> label | App
let collect : type ty.
(module Misc.Monoid with type t = ty) -> (label -> ty) -> abstract -> ty =
fun (module M) op (Abstract t) ->
let r = ref M.empty in
let add x = r := M.union (op x) !r in
let mk_switch = { if_ = (fun ~cond ~branches:_ ~default:_ -> add @@ If cond) }
and mk_app ~f:_ ~args:_ = add App
and mk_dev = { f = (fun ~args:_ ~deps:_ dev -> add @@ Dev dev) } in
let () = map ~mk_switch ~mk_app ~mk_dev t in
!r
(* {2 Dot output} *)
module Dot = struct
type edge_label =
| Functor
| Argument
| Dependency
| Branch of { default : bool }
let as_dot_graph (Abstract t) =
let r = ref 0 in
let new_id () =
incr r;
!r
in
let vertices = ref [] in
let edges = ref [] in
let add r x = r := x :: !r in
let mk_switch =
{
if_ =
(fun ~cond ~branches ~default ->
let id = new_id () in
add vertices (id, If cond);
List.iter
(fun (_, id') -> add edges (id, id', Branch { default = false }))
branches;
add edges (id, default, Branch { default = true });
id);
}
and mk_app ~f ~args =
let id = new_id () in
add vertices (id, App);
add edges (id, f, Functor);
List.iter (fun id' -> add edges (id, id', Argument)) args;
id
and mk_dev =
{
f =
(fun ~args ~deps dev ->
let id = new_id () in
add vertices (id, Dev dev);
List.iter (fun id' -> add edges (id, id', Argument)) args;
List.iter (fun id' -> add edges (id, id', Dependency)) deps;
id);
}
in
let _ = map ~mk_switch ~mk_app ~mk_dev t in
(List.rev !vertices, List.rev !edges)
let pp_vertice ppf (id, label) =
let attrs =
match label with
| App -> [ ("label", "$"); ("shape", "diamond") ]
| If cond -> [ ("label", Fmt.str "If\n%a" Key.pp_deps cond) ]
| Dev dev ->
let name = Fmt.str "%s__%i" (Device.nice_name dev) id in
let label =
Fmt.str "%s\n%s\n%a" name (Device.module_name dev)
Fmt.(list ~sep:(any ", ") Key.pp)
(Device.keys dev)
in
[ ("label", label); ("shape", "box") ]
in
let pp_attr ppf (field, v) = Fmt.pf ppf "%s=%S" field v in
Fmt.pf ppf "%d [%a];" id (Fmt.list ~sep:(Fmt.any ", ") pp_attr) attrs
let pp_edges ppf (id, id', label) =
let attrs =
match label with
| Functor -> [ ("style", "bold"); ("tailport", "sw") ]
| Argument -> []
| Dependency -> [ ("style", "dashed") ]
| Branch { default } ->
let l = [ ("style", "dotted"); ("headport", "n") ] in
if default then ("style", "bold") :: l else l
in
let pp_attr ppf (field, v) = Fmt.pf ppf "%s=%S" field v in
Fmt.pf ppf "%d -> %d [%a];" id id'
(Fmt.list ~sep:(Fmt.any ", ") pp_attr)
attrs
let pp ppf t =
let vertices, edges = as_dot_graph t in
Fmt.pf ppf {|@[<v2>digraph G {@,ordering=out;@,%a@,@,%a@,}@]|}
(Fmt.list ~sep:Fmt.cut pp_vertice)
vertices
(Fmt.list ~sep:Fmt.cut pp_edges)
edges
end
let pp_dot = Dot.pp

120
unikernel/duniverse/mirage/lib/functoria/impl.mli Normal file
View file

@ -0,0 +1,120 @@
(*
* 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.
*)
type 'a t
(** The type for values representing module implementations of type ['a]. *)
type abstract
(** The type for untyped {!t}. *)
type 'a device = ('a, abstract) Device.t
(** The type for device whose dependencies have type {!type:abstract}. *)
val abstract : 'a t -> abstract
(** [abstract i] is [i] with its type erased. *)
val app_has_no_arguments : 'a t -> bool
(** [app_has_no_arguments i] is [true] if the argument list is empty and it is
an application, [false] otherwise. *)
val pp : 'a t Fmt.t
(** [pp] is the pretty-printer for module implementations. *)
val pp_abstract : abstract Fmt.t
(** [pp_abstract] is the pretty-printer for abstract module implementations. *)
val pp_dot : abstract Fmt.t
(** [pp_dot] outputs the dot representation of module implementations. *)
val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t
(** [m $ a] applies the functor [m] to the module [a]. *)
val if_ : bool Key.value -> 'a t -> 'a t -> 'a t
(** [if_t v t1 t2] is [t1] if [v] is resolved to true and [t2] otherwise. *)
val match_ : 'b Key.value -> default:'a t -> ('b * 'a t) list -> 'a t
(** [match_t v cases ~default] chooses the tementation amongst [cases] by
matching the [v]'s value. [default] is chosen if no value matches. *)
val of_device : 'a device -> 'a t
(** [of_device t] is the tementation device [t]. *)
val local_libs : 'a t -> string list
(** [local_libs t] is the list of of local libraries that are needed by [t]. *)
val v :
?packages:Package.t list ->
?packages_v:Package.t list Key.value ->
?runtime_args:Runtime_arg.t list ->
?keys:Key.t list ->
?extra_deps:abstract list ->
?connect:(Info.t -> string -> string list -> 'a Device.code) ->
?dune:(Info.t -> Dune.stanza list) ->
?configure:(Info.t -> unit Action.t) ->
?files:(Info.t -> Fpath.t list) ->
string ->
'a Type.t ->
'a t
(** [v ...] is [of_device @@ Device.v ...] *)
val main :
?pos:string * int * int * int ->
?packages:Package.t list ->
?packages_v:Package.t list Key.value ->
?runtime_args:Runtime_arg.t list ->
?keys:Key.t list ->
?extra_deps:abstract list ->
string ->
'a Type.t ->
'a t
(** [main ... name ty] is [v ... ~connect name ty] where [connect] is
[<name>.start <args>] *)
module Tbl : Hashtbl.S with type key = abstract
(** Hashtbl of implementations. *)
(** {1 Applications} *)
type 'b f_dev = { f : 'a. 'a device -> 'b }
(** The type for iterators on devices. *)
val with_left_most_device : Context.t -> _ t -> 'a f_dev -> 'a
(** [with_left_most_device ctx t f] applies [f] on the left-most device in [f].
[If] node are resolved using [ctx]. *)
val simplify : full:bool -> context:Context.t -> abstract -> abstract
(** [simplify ~full ~context impl] simplifies the implementation [impl]
according to keys present in the [context].
If [full] is [true], then the default values of keys are used in their
absence. Otherwise, absent keys are left un-simplified. *)
val eval : context:Context.t -> abstract -> Device.Graph.t
(** [eval ~context impl] fully evaluates the implementation [impl] according to
keys present in the [context]. It returns a graph composed only of devices.
*)
(** Collections *)
(** The description of a vertex *)
type label = If : _ Key.value -> label | Dev : _ Device.t -> label | App
val collect :
(module Misc.Monoid with type t = 'ty) -> (label -> 'ty) -> abstract -> 'ty
(** [collect (module M) f g] collects the content of [f v] for each vertex [v]
in [g]. *)

135
unikernel/duniverse/mirage/lib/functoria/info.ml Normal file
View file

@ -0,0 +1,135 @@
(*
* 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 Astring
type t = {
config_file : Fpath.t;
name : string;
project_name : string;
output : string option;
keys : Key.Set.t;
runtime_args : Runtime_arg.Set.t;
context : Context.t;
packages : Package.t String.Map.t;
local_libs : string list;
opam :
extra_repo:(string * string) list ->
install:Install.t ->
opam_name:string ->
Opam.t;
}
let name t = t.name
let project_name t = t.project_name
let config_file t = t.config_file
let main t =
let main = match t.output with None -> "main" | Some f -> f in
Fpath.v (main ^ ".ml")
let get t k = Key.get t.context k
let opam t = t.opam
let output t = t.output
let with_output t output = { t with output = Some output }
let libraries ps =
let libs p =
if Package.build_dependency p then String.Set.empty
else String.Set.of_list (Package.libraries p)
in
String.Set.elements
(List.fold_left String.Set.union String.Set.empty (List.map libs ps))
let packages t = List.map snd (String.Map.bindings t.packages)
let libraries t = libraries (packages t) @ t.local_libs
let pins packages =
List.fold_left
(fun acc p -> match Package.pin p with None -> acc | Some u -> u :: acc)
[] packages
let keys t = Key.Set.elements t.keys
let runtime_args t = Runtime_arg.Set.elements t.runtime_args
let context t = t.context
let v ?(config_file = Fpath.v "config.ml") ~packages ~local_libs ~keys
~runtime_args ~context ?configure_cmd ?pre_build_cmd ?lock_location
~build_cmd ~src ~project_name name =
let keys = Key.Set.of_list keys in
let runtime_args = Runtime_arg.Set.of_list runtime_args in
let opam ~extra_repo ~install ~opam_name =
Opam.v ~depends:packages ~install ~pins:(pins packages) ~extra_repo
?configure:configure_cmd ?pre_build:pre_build_cmd ?lock_location
~build:build_cmd ~src ~opam_name name
in
let packages =
List.fold_left
(fun m p ->
let n = Package.name p in
match String.Map.find n m with
| None -> String.Map.add n p m
| Some p' -> (
match Package.merge p p' with
| Some p -> String.Map.add n p m
| None -> m))
String.Map.empty packages
in
{
config_file;
name;
project_name;
keys;
runtime_args;
packages;
local_libs;
context;
output = None;
opam;
}
let pp_packages ?(surround = "") ?sep ppf t =
let pkgs = packages t in
Fmt.pf ppf "%a" (Fmt.iter ?sep List.iter (Package.pp ~surround)) pkgs
let pp verbose ppf ({ name; keys; context; output; _ } as t) =
let show ?(newline = true) name =
Fmt.pf ppf ("@[<2>%-10s@ %a@]" ^^ if newline then "@," else "") name
in
let list = Fmt.iter ~sep:(Fmt.any ",@ ") List.iter Fmt.string in
show "Name" Fmt.string name;
show "Keys" ~newline:(verbose || output <> None) (Key.pps context) keys;
let () =
match output with
| None -> ()
| Some o -> show "Output" ~newline:verbose Fmt.(string) o
in
if verbose then show "Libraries " list (libraries t);
if verbose then
show "Packages" ~newline:false
(pp_packages ?surround:None ~sep:(Fmt.any ",@ "))
t
let t =
let i =
v ~config_file:(Fpath.v "config.ml") ~packages:[] ~local_libs:[] ~keys:[]
~runtime_args:[]
~build_cmd:(fun _ -> "dummy")
~context:Context.empty ~src:`None "dummy" ~project_name:"dummy"
in
Type.v i

92
unikernel/duniverse/mirage/lib/functoria/info.mli Normal file
View file

@ -0,0 +1,92 @@
(*
* 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.
*)
(** Information about the final application. *)
type t
(** The type for information about the final application. *)
val config_file : t -> Fpath.t
(** [config_file t] is the configuration file of the application. *)
val name : t -> string
(** [name t] is the name of the application. *)
val project_name : t -> string
(** [project_name t] is the project name. *)
val main : t -> Fpath.t
(** [main t] is the name of the main application file. *)
val output : t -> string option
(** [output t] is the name of [t]'s output. Derived from {!name} if not set. *)
val with_output : t -> string -> t
(** [with_output t o] is similar to [t] but with the output set to [Some o]. *)
val libraries : t -> string list
(** [libraries t] are the direct OCamlfind dependencies. *)
val packages : t -> Package.t list
(** [packages t] are the opam package dependencies by the project. *)
val opam :
t ->
extra_repo:(string * string) list ->
install:Install.t ->
opam_name:string ->
Opam.t
(** [opam scope t] is [t]'opam file to install in the [scope] context.*)
val keys : t -> Key.t list
(** [keys t] is the list of keys which can be used to configure [t]. *)
val runtime_args : t -> Runtime_arg.t list
(** [runtime_args t] is the list of command-line arguments which can be used to
configure [t] at runtime. *)
val context : t -> Context.t
(** [parsed t] is a value representing the command-line argument being parsed.
*)
val get : t -> 'a Key.key -> 'a
(** [get i k] is the value associated with [k] in [context i]. *)
val v :
?config_file:Fpath.t ->
packages:Package.t list ->
local_libs:string list ->
keys:Key.t list ->
runtime_args:Runtime_arg.t list ->
context:Context.t ->
?configure_cmd:string ->
?pre_build_cmd:(Fpath.t option -> string) ->
?lock_location:(Fpath.t option -> string -> string) ->
build_cmd:(Fpath.t option -> string) ->
src:[ `Auto | `None | `Some of string ] ->
project_name:string ->
string ->
t
(** [create context n r] contains information about the application being built.
*)
val pp : bool -> t Fmt.t
(** {1 Devices} *)
val t : t Type.t

95
unikernel/duniverse/mirage/lib/functoria/install.ml Normal file
View file

@ -0,0 +1,95 @@
(*
* 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.
*)
type t = { bin : (Fpath.t * Fpath.t) list; etc : Fpath.t list }
let v ?(bin = []) ?(etc = []) () = { bin; etc }
let empty = v ()
let dump ppf t =
let bin ppf t = Fmt.Dump.(list (pair Fpath.pp Fpath.pp)) ppf t.bin in
let etc ppf t = Fmt.Dump.(list Fpath.pp) ppf t.etc in
Fmt.Dump.record [ bin; etc ] ppf t
let pp ppf t =
let pp_bin ppf (src, dst) =
Fmt.pf ppf "\n \"%a\" {\"%a\"}" Fpath.pp src Fpath.pp dst
in
let pp_etc ppf file =
Fmt.pf ppf "\n \"%a\" {\"%s\"}" Fpath.pp file Fpath.(basename file)
in
let bins = List.map (Fmt.to_to_string pp_bin) t.bin in
let etcs = List.map (Fmt.to_to_string pp_etc) t.etc in
Fmt.pf ppf "bin: [%s%s]\n" (String.concat "" bins)
(match bins with [] -> "" | _ -> "\n");
Fmt.pf ppf "etc: [%s%s]" (String.concat "" etcs)
(match etcs with [] -> "" | _ -> "\n")
let pp_opam ?subdir () ppf t =
let pp_bin ppf (src, dst) =
Fmt.pf ppf {|"cp" "%adist/%a" "%%{bin}%%/%a"|}
Fmt.(option ~none:(any "") Fpath.pp)
subdir Fpath.pp src Fpath.pp dst
in
let pp_etc ppf etc =
Fmt.pf ppf {|"cp" "%adist/%a" "%%{etc}%%"|}
Fmt.(option ~none:(any "") Fpath.pp)
subdir Fpath.pp etc
in
Fmt.pf ppf "\n%a\n"
(Fmt.list ~sep:(Fmt.any "\n") (fun ppf -> Fmt.pf ppf " [ %a ]" pp_bin))
t.bin;
match t.etc with
| [] -> ()
| _ ->
Fmt.pf ppf "%a\n"
(Fmt.list ~sep:(Fmt.any "\n") (fun ppf -> Fmt.pf ppf " [ %a ]" pp_etc))
t.etc
let promote_artifact ~context_name ~src ~dst =
Dune.stanzaf
{|
(rule
(mode (promote (until-clean)))
(target %a)
(enabled_if (= %%{context_name} "%s"))
(action
(copy %a %%{target}))
)
|}
Fpath.pp dst context_name Fpath.pp
Fpath.(v ".." // src)
let dune ~context_name_for_bin ~context_name_for_etc t =
let bin_rules =
List.map
(fun (src, dst) ->
promote_artifact ~context_name:context_name_for_bin ~src ~dst)
t.bin
in
let etc_rules =
List.map
(fun etc ->
promote_artifact ~context_name:context_name_for_etc ~src:etc ~dst:etc)
t.etc
in
Dune.v (bin_rules @ etc_rules)
let union_etc x y = Fpath.Set.(elements (union (of_list x) (of_list y)))
let union_bin x y = x @ y
let union x y = { bin = union_bin x.bin y.bin; etc = union_etc x.etc y.etc }

48
unikernel/duniverse/mirage/lib/functoria/install.mli Normal file
View file

@ -0,0 +1,48 @@
(*
* 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.
*)
type t
val v : ?bin:(Fpath.t * Fpath.t) list -> ?etc:Fpath.t list -> unit -> t
(** [v ~bin:[(src,dst),...] ~etc ()] is the installation of [src] as [dst] as
binary files, and [etc] as configuration/artifact. *)
val union : t -> t -> t
(** [union a b] merge to sets of installation rules. *)
val empty : t
(** [empty] is the installation of nothing. *)
val pp : t Fmt.t
(** Print the .install rules to install [t] *)
val pp_opam : ?subdir:Fpath.t -> unit -> t Fmt.t
(** Print the opam rules to install [t]. If [~subdir] is provided, this will be
used as prefix (i.e. if your unikernel is in the "tutorial/hello/"
subdirectory (which is passed as [~subdir], the install instructions will
use [cp tutorial/hello/dist/hello.hvt %{bin}%/hello.hvt]). *)
val dune :
context_name_for_bin:string -> context_name_for_etc:string -> t -> Dune.t
(** [dune ~context_name_for_bin ~context_name_for_etc ()] is the dune rules to
promote installed files back in the source tree. A context-name is required
for [bin] and [etc] artifacts. The first one should be the cross-compiler
context and the second one should be the host's compiler context. *)
val dump : t Fmt.t
(** Dump installation rules. *)

Some files were not shown because too many files have changed in this diff Show more