├── test ├── functoria │ ├── lib │ │ ├── empty │ │ │ └── empty │ │ ├── config.ml │ │ └── dune │ ├── tool │ │ ├── empty │ │ │ └── empty │ │ ├── config.ml │ │ ├── test.ml │ │ └── dune │ ├── e2e │ │ ├── test.mli │ │ ├── lib │ │ │ ├── dune │ │ │ ├── e2e.mli │ │ │ └── e2e.ml │ │ ├── app │ │ │ ├── app.ml │ │ │ └── config.ml │ │ ├── cache.t │ │ ├── keys.t │ │ ├── dune │ │ ├── test.ml │ │ ├── describe.t │ │ ├── build.t │ │ ├── clean.t │ │ ├── help.ml │ │ └── configure.t │ ├── test.mli │ ├── context │ │ ├── x.context │ │ ├── y.context │ │ ├── z.context │ │ ├── dune │ │ ├── config.ml │ │ └── run.t │ ├── gen-1 │ │ ├── test.mli │ │ ├── key_gen.ml.expected │ │ ├── info_gen.ml.expected │ │ ├── dune │ │ ├── test.ml │ │ └── main.ml.expected │ ├── gen-2 │ │ ├── test.mli │ │ ├── key_gen.ml.expected │ │ ├── info_gen.ml.expected │ │ ├── dune │ │ ├── main.ml.expected │ │ └── test.ml │ ├── errors │ │ ├── test.ml │ │ ├── dune │ │ └── run.t │ ├── test_cli.mli │ ├── test_key.mli │ ├── test_action.mli │ ├── test_graph.mli │ ├── test_package.mli │ ├── dune │ ├── help │ │ ├── dune │ │ └── config.ml │ ├── query │ │ ├── dune │ │ └── config.ml │ ├── test.ml │ ├── test_package.ml │ └── test_graph.ml ├── mirage │ ├── test.mli │ ├── info_gen │ │ ├── test.mli │ │ ├── key_gen.ml.expected │ │ ├── info_gen.ml.expected │ │ ├── test.ml │ │ ├── dune │ │ └── main.ml.expected │ ├── random-unix │ │ ├── test.mli │ │ ├── dune │ │ └── test.ml │ ├── random-xen │ │ ├── test.mli │ │ ├── dune │ │ └── test.ml │ ├── dune │ ├── action │ │ ├── dune │ │ ├── test.expected │ │ └── test.ml │ ├── help │ │ ├── dune │ │ ├── config.ml │ │ └── gen.ml │ ├── test.ml │ └── query │ │ ├── config.ml │ │ ├── dune │ │ ├── config_dash_in_name.ml │ │ └── gen.ml ├── mirage-runtime │ ├── test.mli │ ├── dune │ └── test.ml ├── functoria-runtime │ ├── .ocamlformat │ ├── main.ml │ ├── info_gen.ml │ ├── key_gen.ml │ ├── dune │ └── app.ml ├── opam-monorepo │ ├── mini-opam-overlays │ │ ├── repo │ │ └── packages │ │ │ ├── fmt │ │ │ └── fmt.0.9.0+dune │ │ │ │ └── opam │ │ │ └── zarith │ │ │ ├── zarith.1.13+dune │ │ │ └── opam │ │ │ └── zarith.1.12+dune+mirage │ │ │ └── opam │ ├── mini-opam-repository │ │ ├── repo │ │ └── packages │ │ │ ├── gmp │ │ │ └── gmp.6.2.9+dune │ │ │ │ └── opam │ │ │ ├── solo5 │ │ │ └── solo5.0.7.1 │ │ │ │ └── opam │ │ │ ├── dune │ │ │ └── dune.3.0.0 │ │ │ │ └── opam │ │ │ ├── mirage-runtime │ │ │ └── mirage-runtime.4.0.0 │ │ │ │ └── opam │ │ │ ├── ocaml-base-compiler │ │ │ └── ocaml-base-compiler.4.13.1 │ │ │ │ └── opam │ │ │ └── ocaml-solo5 │ │ │ └── ocaml-solo5.0.8.0 │ │ │ └── opam │ ├── dune │ ├── unikernel.opam │ └── lock.t ├── f0 │ ├── dune │ ├── f0.mli │ └── f0.ml └── functoria-test │ ├── dune │ ├── functoria_test.mli │ └── functoria_test.ml ├── dune-project ├── lib ├── mirage │ ├── target │ │ ├── mirage_dune.mli │ │ ├── dune │ │ ├── libvirt.mli │ │ ├── mirage_dune.ml │ │ ├── xen.mli │ │ ├── s.ml │ │ ├── mirage_target.ml │ │ └── unix.ml │ ├── impl │ │ ├── mirage_impl_time.mli │ │ ├── dune │ │ ├── mirage_impl_argv.mli │ │ ├── mirage_impl_mclock.mli │ │ ├── mirage_impl_pclock.mli │ │ ├── mirage_impl_icmp.mli │ │ ├── mirage_impl_qubesdb.mli │ │ ├── mirage_impl_tracing.mli │ │ ├── mirage_impl_ethernet.mli │ │ ├── mirage_impl_console.mli │ │ ├── mirage_impl_arpv4.mli │ │ ├── mirage_impl_network.mli │ │ ├── mirage_impl_random.mli │ │ ├── mirage_impl_conduit.mli │ │ ├── mirage_impl_reporter.mli │ │ ├── mirage_impl_pclock.ml │ │ ├── mirage_impl_mclock.ml │ │ ├── mirage_impl_resolver.mli │ │ ├── mirage_impl_kv.mli │ │ ├── mirage_impl_misc.mli │ │ ├── mirage_impl_ethernet.ml │ │ ├── mirage_impl_icmp.ml │ │ ├── mirage_impl_arpv4.ml │ │ ├── mirage_impl_qubesdb.ml │ │ ├── mirage_impl_udp.mli │ │ ├── mirage_impl_tcp.mli │ │ ├── mirage_impl_time.ml │ │ ├── mirage_impl_random.ml │ │ ├── mirage_impl_http.mli │ │ ├── mirage_impl_mimic.ml │ │ ├── mirage_impl_conduit.ml │ │ ├── mirage_impl_argv.ml │ │ ├── mirage_impl_syslog.mli │ │ ├── mirage_impl_console.ml │ │ ├── mirage_impl_block.mli │ │ ├── mirage_impl_stack.mli │ │ ├── mirage_impl_dns.ml │ │ ├── mirage_impl_reporter.ml │ │ ├── mirage_impl_network.ml │ │ ├── mirage_impl_resolver.ml │ │ ├── mirage_impl_happy_eyeballs.ml │ │ ├── mirage_impl_udp.ml │ │ ├── mirage_impl_tracing.ml │ │ ├── mirage_impl_ip.mli │ │ ├── mirage_impl_tcp.ml │ │ ├── mirage_impl_http.ml │ │ ├── mirage_impl_kv.ml │ │ ├── mirage_impl_misc.ml │ │ └── mirage_impl_git.ml │ └── dune └── functoria │ ├── dune │ ├── argv.ml │ ├── makefile.mli │ ├── filegen.mli │ ├── argv.mli │ ├── opam.mli │ ├── misc.mli │ ├── job.mli │ ├── type.ml │ ├── dune.mli │ ├── typeid.mli │ ├── context.mli │ ├── context.ml │ ├── tool.mli │ ├── typeid.ml │ ├── DSL.ml │ ├── context_cache.mli │ ├── misc.ml │ ├── install.mli │ ├── engine.mli │ ├── type.mli │ ├── job.ml │ ├── info.mli │ ├── context_cache.ml │ ├── lib.mli │ ├── install.ml │ ├── filegen.ml │ ├── package.mli │ └── dune.ml ├── bin ├── dune └── main.ml ├── .ocamlformat ├── lib_runtime ├── functoria │ ├── dune │ ├── functoria_runtime.ml │ └── functoria_runtime.mli └── mirage │ ├── dune │ └── mirage_runtime.ml ├── .gitignore ├── Makefile ├── LICENSE.md ├── functoria-runtime.opam ├── mirage-runtime.opam ├── functoria.opam ├── mirage.opam ├── scripts └── ec2.sh └── README.md /test/functoria/lib/empty/empty: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/functoria/tool/empty/empty: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/mirage/test.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /test/functoria/e2e/test.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /test/functoria/test.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /test/functoria/context/x.context: -------------------------------------------------------------------------------- 1 | -t 2 | x 3 | -------------------------------------------------------------------------------- /test/functoria/context/y.context: -------------------------------------------------------------------------------- 1 | -t 2 | y 3 | -------------------------------------------------------------------------------- /test/functoria/gen-1/test.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /test/functoria/gen-2/test.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /test/mirage-runtime/test.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /test/mirage/info_gen/test.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /test/mirage/random-unix/test.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /test/mirage/random-xen/test.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /test/functoria-runtime/.ocamlformat: -------------------------------------------------------------------------------- 1 | disable = true 2 | -------------------------------------------------------------------------------- /test/functoria/context/z.context: -------------------------------------------------------------------------------- 1 | -t 2 | nonexistent 3 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | (name mirage) 3 | (cram enable) 4 | -------------------------------------------------------------------------------- /test/functoria-runtime/main.ml: -------------------------------------------------------------------------------- 1 | ../functoria/gen-1/main.ml.expected -------------------------------------------------------------------------------- /test/functoria/lib/config.ml: -------------------------------------------------------------------------------- 1 | let () = F0.register "my-app" [] 2 | -------------------------------------------------------------------------------- /test/functoria/tool/config.ml: -------------------------------------------------------------------------------- 1 | let () = F0.register "my-app" [] 2 | -------------------------------------------------------------------------------- /test/opam-monorepo/mini-opam-overlays/repo: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | -------------------------------------------------------------------------------- /test/opam-monorepo/mini-opam-repository/repo: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | -------------------------------------------------------------------------------- /test/functoria-runtime/info_gen.ml: -------------------------------------------------------------------------------- 1 | ../functoria/gen-1/info_gen.ml.expected -------------------------------------------------------------------------------- /test/functoria-runtime/key_gen.ml: -------------------------------------------------------------------------------- 1 | ../functoria/gen-1/key_gen.ml.expected -------------------------------------------------------------------------------- /test/functoria/errors/test.ml: -------------------------------------------------------------------------------- 1 | let () = F0.Tool.run_with_argv Sys.argv 2 | -------------------------------------------------------------------------------- /test/functoria/test_cli.mli: -------------------------------------------------------------------------------- 1 | val suite : unit Alcotest.test_case list 2 | -------------------------------------------------------------------------------- /test/functoria/test_key.mli: -------------------------------------------------------------------------------- 1 | val suite : unit Alcotest.test_case list 2 | -------------------------------------------------------------------------------- /test/functoria/test_action.mli: -------------------------------------------------------------------------------- 1 | val suite : unit Alcotest.test_case list 2 | -------------------------------------------------------------------------------- /test/functoria/test_graph.mli: -------------------------------------------------------------------------------- 1 | val suite : unit Alcotest.test_case list 2 | -------------------------------------------------------------------------------- /test/functoria/test_package.mli: -------------------------------------------------------------------------------- 1 | val suite : unit Alcotest.test_case list 2 | -------------------------------------------------------------------------------- /lib/mirage/target/mirage_dune.mli: -------------------------------------------------------------------------------- 1 | val flags : Functoria.Info.t -> string list 2 | -------------------------------------------------------------------------------- /test/functoria/e2e/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name e2e) 3 | (libraries functoria)) 4 | -------------------------------------------------------------------------------- /test/functoria/gen-1/key_gen.ml.expected: -------------------------------------------------------------------------------- 1 | 2 | let runtime_keys = List.combine [] [] 3 | -------------------------------------------------------------------------------- /test/f0/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name f0) 3 | (package functoria) 4 | (libraries functoria)) 5 | -------------------------------------------------------------------------------- /test/mirage/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (package mirage) 4 | (libraries mirage alcotest)) 5 | -------------------------------------------------------------------------------- /test/mirage/action/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (package mirage) 4 | (libraries alcotest mirage)) 5 | -------------------------------------------------------------------------------- /test/mirage/info_gen/key_gen.ml.expected: -------------------------------------------------------------------------------- 1 | let target () = `Unix 2 | 3 | let runtime_keys = List.combine [] [] 4 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name mirage) 4 | (package mirage) 5 | (libraries mirage)) 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.23.0 2 | profile = conventional 3 | break-infix = fit-or-vertical 4 | parse-docstrings = true 5 | -------------------------------------------------------------------------------- /test/functoria-runtime/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | (package functoria-runtime) 4 | (libraries functoria-runtime)) 5 | -------------------------------------------------------------------------------- /test/mirage-runtime/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (package mirage-runtime) 4 | (libraries mirage-runtime alcotest)) 5 | -------------------------------------------------------------------------------- /test/functoria-test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name functoria_test) 3 | (public_name functoria.test) 4 | (libraries functoria)) 5 | -------------------------------------------------------------------------------- /test/functoria/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (package functoria) 4 | (libraries f0 alcotest cmdliner rresult astring)) 5 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_time.mli: -------------------------------------------------------------------------------- 1 | type time 2 | 3 | val time : time Functoria.typ 4 | val default_time : time Functoria.impl 5 | -------------------------------------------------------------------------------- /test/functoria/tool/test.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let argv = Array.append Sys.argv [| "--dry-run" |] in 3 | F0.Tool.run_with_argv argv 4 | -------------------------------------------------------------------------------- /lib/mirage/impl/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_impl) 3 | (public_name mirage.impl) 4 | (libraries mirage.key) 5 | (wrapped false)) 6 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_argv.mli: -------------------------------------------------------------------------------- 1 | val default_argv : Functoria.argv Functoria.impl 2 | val no_argv : Functoria.argv Functoria.impl 3 | -------------------------------------------------------------------------------- /lib/mirage/target/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_target) 3 | (public_name mirage.target) 4 | (libraries mirage.key mirage.impl logs)) 5 | -------------------------------------------------------------------------------- /lib_runtime/functoria/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name functoria_runtime) 3 | (public_name functoria-runtime) 4 | (libraries bytes cmdliner fmt)) 5 | -------------------------------------------------------------------------------- /test/mirage/help/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name config) 3 | (libraries mirage)) 4 | 5 | (cram 6 | (package mirage) 7 | (deps config.exe)) 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *~ 3 | \.\#* 4 | \#*# 5 | *.native 6 | *.byte 7 | *.install 8 | _tests/ 9 | .merlin 10 | _opam 11 | .DS_Store 12 | -------------------------------------------------------------------------------- /test/functoria/errors/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries f0)) 4 | 5 | (cram 6 | (package functoria) 7 | (deps ./test.exe)) 8 | -------------------------------------------------------------------------------- /test/functoria/help/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name config) 3 | (libraries f0)) 4 | 5 | (cram 6 | (package functoria) 7 | (deps config.exe)) 8 | -------------------------------------------------------------------------------- /test/mirage/info_gen/info_gen.ml.expected: -------------------------------------------------------------------------------- 1 | let libraries = [ 2 | ] 3 | 4 | let info = Mirage_runtime.{ 5 | name = "foo"; 6 | libraries 7 | } -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_mclock.mli: -------------------------------------------------------------------------------- 1 | type mclock 2 | 3 | val mclock : mclock Functoria.typ 4 | val default_monotonic_clock : mclock Functoria.impl 5 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_pclock.mli: -------------------------------------------------------------------------------- 1 | type pclock 2 | 3 | val pclock : pclock Functoria.typ 4 | val default_posix_clock : pclock Functoria.impl 5 | -------------------------------------------------------------------------------- /lib_runtime/mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_runtime) 3 | (public_name mirage-runtime) 4 | (libraries functoria-runtime lwt ipaddr logs fmt)) 5 | -------------------------------------------------------------------------------- /test/functoria/lib/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name config) 3 | (libraries f0)) 4 | 5 | (cram 6 | (package functoria) 7 | (deps config.exe empty/empty)) 8 | -------------------------------------------------------------------------------- /test/functoria/tool/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries f0)) 4 | 5 | (cram 6 | (package functoria) 7 | (deps test.exe config.ml empty/empty)) 8 | -------------------------------------------------------------------------------- /test/opam-monorepo/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (package mirage) 3 | (deps 4 | unikernel.opam 5 | (source_tree mini-opam-overlays/) 6 | (source_tree mini-opam-repository/))) 7 | -------------------------------------------------------------------------------- /test/functoria/query/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name config) 3 | (libraries f0)) 4 | 5 | (cram 6 | (package functoria) 7 | (deps config.exe ../../../functoria-runtime.opam)) 8 | -------------------------------------------------------------------------------- /test/opam-monorepo/mini-opam-overlays/packages/fmt/fmt.0.9.0+dune/opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | depends: ["dune"] 3 | dev-repo: "fmt" 4 | url { 5 | src: "https://fmt.src" 6 | } -------------------------------------------------------------------------------- /test/opam-monorepo/mini-opam-repository/packages/gmp/gmp.6.2.9+dune/opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | depends: ["dune"] 3 | dev-repo: "gmp" 4 | url { 5 | src: "https://gmp.src" 6 | } -------------------------------------------------------------------------------- /test/opam-monorepo/mini-opam-repository/packages/solo5/solo5.0.7.1/opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | depends: [] 3 | dev-repo: "solo5" 4 | url { 5 | src: "https://solo5.src" 6 | } -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_icmp.mli: -------------------------------------------------------------------------------- 1 | type icmpv4 2 | 3 | val icmpv4 : icmpv4 Functoria.typ 4 | val direct_icmpv4 : Mirage_impl_ip.ipv4 Functoria.impl -> icmpv4 Functoria.impl 5 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_qubesdb.mli: -------------------------------------------------------------------------------- 1 | type qubesdb 2 | 3 | val qubesdb : qubesdb Functoria.typ 4 | val default_qubesdb : qubesdb Functoria.impl 5 | val pkg : Functoria.package 6 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_tracing.mli: -------------------------------------------------------------------------------- 1 | type tracing = Functoria.job 2 | 3 | val tracing : tracing Functoria.typ 4 | val mprof_trace : size:int -> unit -> tracing Functoria.impl 5 | -------------------------------------------------------------------------------- /test/functoria/context/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name config) 3 | (libraries f0)) 4 | 5 | (cram 6 | (package functoria) 7 | (deps ./config.exe x.context y.context z.context)) 8 | -------------------------------------------------------------------------------- /test/functoria/e2e/app/app.ml: -------------------------------------------------------------------------------- 1 | module Make (_ : sig end) = struct 2 | let start () = 3 | Fmt.pr "Success: vote=%s hello=%s\n%!" Key_gen.(vote ()) Key_gen.(hello ()) 4 | end 5 | -------------------------------------------------------------------------------- /test/opam-monorepo/mini-opam-overlays/packages/zarith/zarith.1.13+dune/opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | depends: ["dune"] 3 | dev-repo: "zarith" 4 | url { 5 | src: "https://zarith.src" 6 | } -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_ethernet.mli: -------------------------------------------------------------------------------- 1 | type ethernet 2 | 3 | val ethernet : ethernet Functoria.typ 4 | val etif : Mirage_impl_network.network Functoria.impl -> ethernet Functoria.impl 5 | -------------------------------------------------------------------------------- /test/opam-monorepo/mini-opam-repository/packages/dune/dune.3.0.0/opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | depends: ["ocaml-base-compiler"] 3 | dev-repo: "" 4 | url { 5 | src: "https://mirage.src" 6 | } -------------------------------------------------------------------------------- /test/opam-monorepo/mini-opam-repository/packages/mirage-runtime/mirage-runtime.4.0.0/opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | depends: ["dune"] 3 | dev-repo: "mirage" 4 | url { 5 | src: "https://mirage.src" 6 | } -------------------------------------------------------------------------------- /test/opam-monorepo/mini-opam-repository/packages/ocaml-base-compiler/ocaml-base-compiler.4.13.1/opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | depends: [] 3 | dev-repo: "base" 4 | url { 5 | src: "https://base.src" 6 | } -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_console.mli: -------------------------------------------------------------------------------- 1 | type console 2 | 3 | val console : console Functoria.typ 4 | val default_console : console Functoria.impl 5 | val custom_console : string -> console Functoria.impl 6 | -------------------------------------------------------------------------------- /lib/mirage/target/libvirt.mli: -------------------------------------------------------------------------------- 1 | open Functoria 2 | 3 | val filename : name:string -> Fpath.t 4 | val configure_main : name:string -> unit Action.t 5 | val configure_virtio : name:string -> unit Action.t 6 | -------------------------------------------------------------------------------- /test/opam-monorepo/mini-opam-repository/packages/ocaml-solo5/ocaml-solo5.0.8.0/opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | depends: ["solo5"] 3 | dev-repo: "ocaml-solo5" 4 | url { 5 | src: "https://ocaml-solo5.src" 6 | } -------------------------------------------------------------------------------- /test/mirage/action/test.expected: -------------------------------------------------------------------------------- 1 | unix 2 | ==== 3 | 4 | 5 | hvt 6 | === 7 | 8 | Write to manifest.json (mode: default, purpose: Solo5 application manifest file) 9 | Write to manifest.ml (0 bytes) 10 | 11 | -------------------------------------------------------------------------------- /test/functoria-test/functoria_test.mli: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Functoria.DSL 3 | 4 | val run : 5 | ?keys:Key.Set.elt list -> 6 | ?init:job impl list -> 7 | context -> 8 | 'a impl -> 9 | unit Action.t 10 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_arpv4.mli: -------------------------------------------------------------------------------- 1 | type arpv4 2 | 3 | val arpv4 : arpv4 Functoria.typ 4 | 5 | val arp : 6 | ?time:Mirage_impl_time.time Functoria.impl -> 7 | Mirage_impl_ethernet.ethernet Functoria.impl -> 8 | arpv4 Functoria.impl 9 | -------------------------------------------------------------------------------- /test/mirage-runtime/test.ml: -------------------------------------------------------------------------------- 1 | let t = { Mirage_runtime.name = "foo"; libraries = [ ("bar", "n/a") ] } 2 | let test_info () = Alcotest.(check string) "name" t.name "foo" 3 | let () = Alcotest.run "mirage" [ ("basic", [ ("info", `Quick, test_info) ]) ] 4 | -------------------------------------------------------------------------------- /test/opam-monorepo/mini-opam-overlays/packages/zarith/zarith.1.12+dune+mirage/opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | depends: ["dune" "gmp"] 3 | dev-repo: "zarith" 4 | url { 5 | src: "https://github.com/ocaml/zarith.git" 6 | } 7 | tags: [ "cross-compile" ] 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean doc test 2 | 3 | all: 4 | dune build 5 | 6 | clean: 7 | dune clean 8 | 9 | doc: 10 | dune build @doc 11 | 12 | test: 13 | dune runtest 14 | INSIDE_FUNCTORIA_TESTS=1 dune exec -- test/functoria/e2e/test.exe 15 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_network.mli: -------------------------------------------------------------------------------- 1 | type network 2 | 3 | val network : network Functoria.typ 4 | val netif : ?group:string -> string -> network Functoria.impl 5 | val default_network : network Functoria.impl 6 | val all_networks : string list ref 7 | -------------------------------------------------------------------------------- /test/mirage/test.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let t = kv_ro @-> job 4 | 5 | let test_typ () = 6 | Alcotest.(check string) "pp" (Fmt.to_to_string Mirage.Type.pp t) "(_ -> _)" 7 | 8 | let () = Alcotest.run "mirage" [ ("basic", [ ("pp", `Quick, test_typ) ]) ] 9 | -------------------------------------------------------------------------------- /lib/functoria/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name functoria) 3 | (public_name functoria) 4 | (libraries 5 | uri 6 | emile 7 | unix 8 | cmdliner 9 | rresult 10 | fmt 11 | astring 12 | fpath 13 | bos 14 | fmt.cli 15 | logs.fmt 16 | fmt.tty 17 | logs.cli)) 18 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_random.mli: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_time 3 | open Mirage_impl_mclock 4 | 5 | type random 6 | 7 | val random : random typ 8 | val rng : ?time:time impl -> ?mclock:mclock impl -> unit -> random impl 9 | val default_random : random impl 10 | -------------------------------------------------------------------------------- /test/functoria-runtime/app.ml: -------------------------------------------------------------------------------- 1 | module type K = sig 2 | val runtime_keys : (unit Cmdliner.Term.t * string) list 3 | end 4 | 5 | module type I = sig 6 | val info : Functoria_runtime.info 7 | end 8 | 9 | module Make (K : K) (I : I) = struct 10 | let start _ _ = () 11 | end 12 | -------------------------------------------------------------------------------- /test/functoria/test.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Alcotest.run "functoria" 3 | [ 4 | ("cli", Test_cli.suite); 5 | ("package", Test_package.suite); 6 | ("graph", Test_graph.suite); 7 | ("action", Test_action.suite); 8 | ("key", Test_key.suite); 9 | ] 10 | -------------------------------------------------------------------------------- /lib/mirage/target/mirage_dune.ml: -------------------------------------------------------------------------------- 1 | open Mirage_impl_misc 2 | 3 | let flags _ = 4 | (* Disable "70 [missing-mli] Missing interface file." as we are only 5 | generating .ml files currently. *) 6 | [ ":standard"; "-w"; "-70" ] 7 | @ if terminal () then [ "-color"; "always" ] else [] 8 | -------------------------------------------------------------------------------- /test/functoria/e2e/cache.t: -------------------------------------------------------------------------------- 1 | Test that the cache is escaping entries correctly: 2 | 3 | $ ./test.exe configure --file app/config.ml --vote="foo;;bar;;;\n\nllll;;;sdaads;;\n\t\0" 4 | $ ./test.exe build --file app/config.ml 5 | $ cat app/test/vote 6 | foo;;bar;;;\n\nllll;;;sdaads;;\n\t\0 7 | -------------------------------------------------------------------------------- /test/mirage/help/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = main "App" job 4 | 5 | let key = 6 | let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in 7 | Key.(create "hello" Arg.(opt string "Hello World!" doc)) 8 | 9 | let () = register ~keys:[ Key.v key ] "noop" [ main ] 10 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_conduit.mli: -------------------------------------------------------------------------------- 1 | open Functoria 2 | 3 | type conduit 4 | 5 | val pkg : package 6 | val conduit : conduit typ 7 | 8 | val conduit_direct : 9 | ?tls:bool -> 10 | ?random:Mirage_impl_random.random impl -> 11 | Mirage_impl_stack.stackv4v6 impl -> 12 | conduit impl 13 | -------------------------------------------------------------------------------- /test/mirage/query/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = main "App" job 4 | 5 | let key = 6 | let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in 7 | Key.(create "hello" Arg.(opt string "Hello World!" doc)) 8 | 9 | let () = register ~keys:[ Key.v key ] ~src:`None "noop" [ main ] 10 | -------------------------------------------------------------------------------- /test/functoria/e2e/lib/e2e.mli: -------------------------------------------------------------------------------- 1 | open Functoria.DSL 2 | 3 | val register : 4 | ?packages:package list -> 5 | ?keys:abstract_key list -> 6 | ?init:job impl list -> 7 | ?src:[ `Auto | `None | `Some of string ] -> 8 | string -> 9 | job impl list -> 10 | unit 11 | 12 | val run : unit -> unit 13 | -------------------------------------------------------------------------------- /test/mirage/query/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name config) 3 | (modules config) 4 | (libraries mirage)) 5 | 6 | (executable 7 | (name config_dash_in_name) 8 | (modules config_dash_in_name) 9 | (libraries mirage)) 10 | 11 | (cram 12 | (package mirage) 13 | (deps config.exe config_dash_in_name.exe)) 14 | -------------------------------------------------------------------------------- /test/mirage/query/config_dash_in_name.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = main "App" job 4 | 5 | let key = 6 | let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in 7 | Key.(create "hello" Arg.(opt string "Hello World!" doc)) 8 | 9 | let () = register ~keys:[ Key.v key ] ~src:`None "noop-functor.v0" [ main ] 10 | -------------------------------------------------------------------------------- /test/functoria/help/config.ml: -------------------------------------------------------------------------------- 1 | open F0 2 | open Functoria 3 | 4 | let main = Functoria.(main "App" job) 5 | 6 | let key = 7 | let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in 8 | Key.(create "hello" Arg.(opt string "Hello World!" doc)) 9 | 10 | let () = register ~keys:[ Key.v key ] ~src:`None "noop" [ main ] 11 | -------------------------------------------------------------------------------- /test/mirage/random-xen/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (modules test) 4 | (libraries functoria.test fmt mirage)) 5 | 6 | (rule 7 | (targets main.ml) 8 | (action 9 | (run ./test.exe))) 10 | 11 | (rule 12 | (alias runtest) 13 | (package mirage) 14 | (action 15 | (progn 16 | (diff main.ml.expected main.ml)))) 17 | -------------------------------------------------------------------------------- /test/functoria/e2e/app/config.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open E2e 3 | 4 | let main = main "App.Make" (job @-> job) 5 | 6 | let key = 7 | let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in 8 | Key.(create "hello" Arg.(opt string "Hello World!" doc)) 9 | 10 | let () = register ~keys:[ Key.v key ] "noop" [ main $ noop ] 11 | -------------------------------------------------------------------------------- /test/mirage/random-unix/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (modules test) 4 | (libraries functoria.test fmt mirage)) 5 | 6 | (rule 7 | (targets main.ml) 8 | (action 9 | (run ./test.exe))) 10 | 11 | (rule 12 | (alias runtest) 13 | (package mirage) 14 | (action 15 | (progn 16 | (diff main.ml.expected main.ml)))) 17 | -------------------------------------------------------------------------------- /lib/mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name mirage.key) 3 | (name mirage_key) 4 | (wrapped false) 5 | (libraries ipaddr logs astring functoria mirage-runtime bos) 6 | (modules mirage_key)) 7 | 8 | (library 9 | (public_name mirage) 10 | (wrapped false) 11 | (libraries mirage.impl mirage.target) 12 | (modules :standard \ mirage_key)) 13 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_reporter.mli: -------------------------------------------------------------------------------- 1 | type reporter = Functoria.job 2 | 3 | val reporter : reporter Functoria.typ 4 | 5 | val default_reporter : 6 | ?clock:Mirage_impl_pclock.pclock Functoria.impl -> 7 | ?ring_size:int -> 8 | ?level:Logs.level option -> 9 | unit -> 10 | reporter Functoria.impl 11 | 12 | val no_reporter : reporter Functoria.impl 13 | -------------------------------------------------------------------------------- /test/functoria/query/config.ml: -------------------------------------------------------------------------------- 1 | open F0 2 | open Functoria 3 | 4 | let main = Functoria.(main ~extra_deps:[ dep (app_info ()) ] "App" job) 5 | 6 | let key = 7 | let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in 8 | Key.(create "hello" Arg.(opt string "Hello World!" doc)) 9 | 10 | let () = register ~keys:[ Key.v key ] ~src:`None "noop" [ main ] 11 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_pclock.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | 3 | type pclock = PCLOCK 4 | 5 | let pclock = Type.v PCLOCK 6 | 7 | let default_posix_clock = 8 | let packages_v = 9 | Mirage_key.(if_ is_unix) 10 | [ package ~min:"3.0.0" ~max:"5.0.0" "mirage-clock-unix" ] 11 | [ package ~min:"4.2.0" ~max:"5.0.0" "mirage-clock-solo5" ] 12 | in 13 | impl ~packages_v "Pclock" pclock 14 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_mclock.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | 3 | type mclock = MCLOCK 4 | 5 | let mclock = Type.v MCLOCK 6 | 7 | let default_monotonic_clock = 8 | let packages_v = 9 | Mirage_key.(if_ is_unix) 10 | [ package ~min:"4.1.0" ~max:"5.0.0" "mirage-clock-unix" ] 11 | [ package ~min:"4.2.0" ~max:"5.0.0" "mirage-clock-solo5" ] 12 | in 13 | impl ~packages_v "Mclock" mclock 14 | -------------------------------------------------------------------------------- /test/functoria/e2e/keys.t: -------------------------------------------------------------------------------- 1 | Test keys. 2 | 3 | $ ./test.exe configure --file app/config.ml 4 | $ ./test.exe build --file app/config.ml 5 | $ cat app/test/vote 6 | cat 7 | $ ./test.exe clean --file app/config.ml 8 | 9 | Change the key at configure time: 10 | 11 | $ ./test.exe configure --file app/config.ml --vote=dog 12 | $ ./test.exe build --file app/config.ml 13 | $ cat app/test/vote 14 | dog 15 | -------------------------------------------------------------------------------- /test/f0/f0.mli: -------------------------------------------------------------------------------- 1 | open Functoria.DSL 2 | 3 | val register : 4 | ?packages:package list -> 5 | ?keys:abstract_key list -> 6 | ?init:job impl list -> 7 | ?src:[ `Auto | `None | `Some of string ] -> 8 | string -> 9 | job impl list -> 10 | unit 11 | 12 | module Tool : sig 13 | val run_with_argv : 14 | ?help_ppf:Format.formatter -> 15 | ?err_ppf:Format.formatter -> 16 | string array -> 17 | unit 18 | end 19 | -------------------------------------------------------------------------------- /test/functoria/gen-2/key_gen.ml.expected: -------------------------------------------------------------------------------- 1 | let hello = Functoria_runtime.Key.create 2 | (Functoria_runtime.Arg.opt Cmdliner.Arg.string "Hello World!" (Cmdliner.Arg.info 3 | ~docs:"APPLICATION OPTIONS" ?docv:(None) ?doc:(Some "How to say hello. ") 4 | ?env:(None) ["hello"])) 5 | 6 | let hello_t = Functoria_runtime.Key.term hello 7 | 8 | let hello () = Functoria_runtime.Key.get hello 9 | 10 | let runtime_keys = List.combine [hello_t] ["hello"] 11 | -------------------------------------------------------------------------------- /test/functoria/e2e/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (modules test) 4 | (libraries e2e alcotest cmdliner rresult astring)) 5 | 6 | (executable 7 | (name help) 8 | (modules help) 9 | (libraries astring fmt)) 10 | 11 | (cram 12 | (deps 13 | test.exe 14 | help.exe 15 | (source_tree app) 16 | (source_tree lib) 17 | (package functoria) 18 | (package functoria-runtime)) 19 | (enabled_if 20 | (<> %{architecture} "i386")) 21 | (package functoria)) 22 | -------------------------------------------------------------------------------- /test/mirage/info_gen/test.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let test () = 4 | let context = Key.add_to_context Key.target `Unix Key.empty_context in 5 | let sigs = job @-> info @-> job in 6 | let job = 7 | main "App.Make" sigs $ keys default_argv $ app_info_with_opam_deps [] 8 | in 9 | Functoria_test.run ~keys:[ Key.v Key.target ] context job 10 | 11 | let () = 12 | match Functoria.Action.run (test ()) with 13 | | Ok () -> () 14 | | Error (`Msg e) -> failwith e 15 | -------------------------------------------------------------------------------- /lib/mirage/target/xen.mli: -------------------------------------------------------------------------------- 1 | open Functoria 2 | 3 | module Substitutions : sig 4 | type v = 5 | | Name 6 | | Kernel 7 | | Memory 8 | | Block of Mirage_impl_block.block_t 9 | | Network of string 10 | 11 | type t = (v * string) list 12 | 13 | val lookup : t -> v -> string 14 | val defaults : Functoria.Info.t -> t 15 | end 16 | 17 | val configure_main_xl : 18 | ?substitutions:Substitutions.t -> 19 | ext:string -> 20 | Functoria.Info.t -> 21 | unit Action.t 22 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_resolver.mli: -------------------------------------------------------------------------------- 1 | type resolver 2 | 3 | open Functoria 4 | open Mirage_impl_random 5 | open Mirage_impl_mclock 6 | open Mirage_impl_pclock 7 | open Mirage_impl_time 8 | 9 | val resolver : resolver typ 10 | 11 | val resolver_dns : 12 | ?ns:string list -> 13 | ?time:time impl -> 14 | ?mclock:mclock impl -> 15 | ?pclock:pclock impl -> 16 | ?random:random impl -> 17 | Mirage_impl_stack.stackv4v6 impl -> 18 | resolver impl 19 | 20 | val resolver_unix_system : resolver Functoria.impl 21 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_kv.mli: -------------------------------------------------------------------------------- 1 | type ro 2 | 3 | val ro : ro Functoria.typ 4 | val direct_kv_ro : string -> ro Functoria.impl 5 | val crunch : string -> ro Functoria.impl 6 | 7 | val generic_kv_ro : 8 | ?group:string -> 9 | ?key:[ `Crunch | `Direct ] Functoria.value -> 10 | string -> 11 | ro Functoria.impl 12 | 13 | type rw 14 | 15 | val rw : rw Functoria.typ 16 | val direct_kv_rw : string -> rw Functoria.impl 17 | 18 | val mem_kv_rw : 19 | ?clock:Mirage_impl_pclock.pclock Functoria.impl -> unit -> rw Functoria.impl 20 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_misc.mli: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Log : Logs.LOG 3 | 4 | val get_target : Info.t -> Mirage_key.mode 5 | val connect_err : string -> int -> string 6 | val pp_key : Format.formatter -> 'a Key.key -> unit 7 | 8 | val query_ocamlfind : 9 | ?recursive:bool -> 10 | ?format:string -> 11 | ?predicates:string -> 12 | string list -> 13 | string list Action.t 14 | 15 | val opam_prefix : string Action.t Lazy.t 16 | val extra_c_artifacts : string -> string list -> string list Action.t 17 | val terminal : unit -> bool 18 | -------------------------------------------------------------------------------- /test/functoria/gen-1/info_gen.ml.expected: -------------------------------------------------------------------------------- 1 | let libraries = [ 2 | "base-bigarray", "base"; 3 | "base-threads", "base"; 4 | "base-unix", "base"; 5 | "cmdliner", "1.0.4"; 6 | "conf-m4", "1"; 7 | "dune", "2.0.0"; 8 | "fmt", "0.8.8"; 9 | "ocaml", "4.08.1"; 10 | "ocaml-base-compiler", "4.08.1"; 11 | "ocaml-config", "1"; 12 | "ocamlbuild", "0.14.0"; 13 | "ocamlfind", "1.8.1"; 14 | "seq", "base"; 15 | "stdlib-shims", "0.1.0"; 16 | "topkg", "1.0.1"] 17 | 18 | let info = Functoria_runtime.{ 19 | name = "foo"; 20 | libraries 21 | } -------------------------------------------------------------------------------- /test/functoria/gen-2/info_gen.ml.expected: -------------------------------------------------------------------------------- 1 | let libraries = [ 2 | "base-bigarray", "base"; 3 | "base-threads", "base"; 4 | "base-unix", "base"; 5 | "cmdliner", "1.0.4"; 6 | "conf-m4", "1"; 7 | "dune", "2.0.0"; 8 | "fmt", "0.8.8"; 9 | "ocaml", "4.08.1"; 10 | "ocaml-base-compiler", "4.08.1"; 11 | "ocaml-config", "1"; 12 | "ocamlbuild", "0.14.0"; 13 | "ocamlfind", "1.8.1"; 14 | "seq", "base"; 15 | "stdlib-shims", "0.1.0"; 16 | "topkg", "1.0.1"] 17 | 18 | let info = Functoria_runtime.{ 19 | name = "foo"; 20 | libraries 21 | } -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_ethernet.ml: -------------------------------------------------------------------------------- 1 | module Key = Mirage_key 2 | open Functoria 3 | open Mirage_impl_misc 4 | open Mirage_impl_network 5 | 6 | type ethernet = ETHERNET 7 | 8 | let ethernet = Type.v ETHERNET 9 | 10 | let etif_conf = 11 | let packages = [ package ~min:"3.0.0" ~max:"4.0.0" "ethernet" ] in 12 | let connect _ m = function 13 | | [ eth ] -> Fmt.str "%s.connect %s" m eth 14 | | _ -> failwith (connect_err "ethernet" 1) 15 | in 16 | impl ~packages ~connect "Ethernet.Make" (network @-> ethernet) 17 | 18 | let etif network = etif_conf $ network 19 | -------------------------------------------------------------------------------- /test/mirage/info_gen/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (modules test) 4 | (libraries functoria.test fmt mirage)) 5 | 6 | (rule 7 | (targets key_gen.ml info_gen.ml main.ml) 8 | (action 9 | (run ./test.exe))) 10 | 11 | (rule 12 | (alias runtest) 13 | (package mirage) 14 | (action 15 | (diff key_gen.ml.expected key_gen.ml))) 16 | 17 | (rule 18 | (alias runtest) 19 | (package mirage) 20 | (action 21 | (diff info_gen.ml.expected info_gen.ml))) 22 | 23 | (rule 24 | (alias runtest) 25 | (package mirage) 26 | (action 27 | (diff main.ml.expected main.ml))) 28 | -------------------------------------------------------------------------------- /test/functoria/gen-1/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (modules test) 4 | (libraries functoria_test fmt functoria)) 5 | 6 | (rule 7 | (targets key_gen.ml info_gen.ml main.ml) 8 | (action 9 | (run ./test.exe))) 10 | 11 | (rule 12 | (alias runtest) 13 | (package functoria) 14 | (action 15 | (diff key_gen.ml.expected key_gen.ml))) 16 | 17 | (rule 18 | (alias runtest) 19 | (package functoria) 20 | (action 21 | (diff info_gen.ml.expected info_gen.ml))) 22 | 23 | (rule 24 | (alias runtest) 25 | (package functoria) 26 | (action 27 | (diff main.ml.expected main.ml))) 28 | -------------------------------------------------------------------------------- /test/functoria/gen-2/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (modules test) 4 | (libraries functoria_test fmt functoria)) 5 | 6 | (rule 7 | (targets key_gen.ml info_gen.ml main.ml) 8 | (action 9 | (run ./test.exe))) 10 | 11 | (rule 12 | (alias runtest) 13 | (package functoria) 14 | (action 15 | (diff key_gen.ml.expected key_gen.ml))) 16 | 17 | (rule 18 | (alias runtest) 19 | (package functoria) 20 | (action 21 | (diff info_gen.ml.expected info_gen.ml))) 22 | 23 | (rule 24 | (alias runtest) 25 | (package functoria) 26 | (action 27 | (diff main.ml.expected main.ml))) 28 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_icmp.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_ip 3 | open Mirage_impl_misc 4 | 5 | type 'a icmp = ICMP 6 | type icmpv4 = v4 icmp 7 | 8 | let icmp = Type.v ICMP 9 | let icmpv4 : icmpv4 typ = icmp 10 | 11 | let icmpv4_direct () = 12 | let packages_v = right_tcpip_library ~sublibs:[ "icmpv4" ] "tcpip" in 13 | let connect _ modname = function 14 | | [ ip ] -> Fmt.str "%s.connect %s" modname ip 15 | | _ -> failwith (connect_err "icmpv4" 1) 16 | in 17 | impl ~packages_v ~connect "Icmpv4.Make" (ip @-> icmp) 18 | 19 | let direct_icmpv4 ip = icmpv4_direct () $ ip 20 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_arpv4.ml: -------------------------------------------------------------------------------- 1 | module Key = Mirage_key 2 | open Functoria 3 | open Mirage_impl_ethernet 4 | open Mirage_impl_time 5 | open Mirage_impl_misc 6 | 7 | type arpv4 = Arpv4 8 | 9 | let arpv4 = Type.v Arpv4 10 | 11 | let arp_conf = 12 | let packages = 13 | [ package ~min:"3.0.0" ~max:"4.0.0" ~sublibs:[ "mirage" ] "arp" ] 14 | in 15 | let connect _ modname = function 16 | | [ eth; _time ] -> Fmt.str "%s.connect %s" modname eth 17 | | _ -> failwith (connect_err "arp" 3) 18 | in 19 | impl ~packages ~connect "Arp.Make" (ethernet @-> time @-> arpv4) 20 | 21 | let arp ?(time = default_time) (eth : ethernet impl) = arp_conf $ eth $ time 22 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_qubesdb.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Key = Mirage_key 3 | open Mirage_impl_misc 4 | 5 | type qubesdb = QUBES_DB 6 | 7 | let qubesdb = Type.v QUBES_DB 8 | let pkg = package ~min:"0.9.0" ~max:"0.10.0" "mirage-qubes" 9 | 10 | let default_qubesdb = 11 | let packages = [ pkg ] in 12 | let configure i = 13 | match get_target i with 14 | | `Qubes | `Xen -> Action.ok () 15 | | _ -> 16 | Action.error 17 | "Qubes DB invoked for an unsupported target; qubes and xen are \ 18 | supported" 19 | in 20 | let connect _ modname _args = Fmt.str "%s.connect ~domid:0 ()" modname in 21 | impl ~packages ~configure ~connect "Qubes.DB" qubesdb 22 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_udp.mli: -------------------------------------------------------------------------------- 1 | type 'a udp 2 | 3 | val udp : 'a udp Functoria.typ 4 | 5 | type udpv4v6 = Mirage_impl_ip.v4v6 udp 6 | 7 | val udpv4v6 : udpv4v6 Functoria.typ 8 | 9 | val direct_udp : 10 | ?random:Mirage_impl_random.random Functoria.impl -> 11 | 'a Mirage_impl_ip.ip Functoria.impl -> 12 | 'a udp Functoria.impl 13 | 14 | val socket_udpv4v6 : 15 | ?group:string -> 16 | Ipaddr.V4.t option -> 17 | Ipaddr.V6.t option -> 18 | udpv4v6 Functoria.impl 19 | 20 | val udpv4v6_socket_conf : 21 | ipv4_only:bool Mirage_key.key -> 22 | ipv6_only:bool Mirage_key.key -> 23 | Ipaddr.V4.Prefix.t Mirage_key.key -> 24 | Ipaddr.V6.Prefix.t option Mirage_key.key -> 25 | udpv4v6 Functoria.impl 26 | -------------------------------------------------------------------------------- /test/functoria/context/config.ml: -------------------------------------------------------------------------------- 1 | open F0 2 | open Functoria 3 | 4 | let x = Impl.v ~packages:[ package "x" ] "X" job 5 | let y = Impl.v ~packages:[ package "y" ] "Y" job 6 | 7 | let target_conv : _ Cmdliner.Arg.conv = 8 | let parser, printer = Cmdliner.Arg.enum [ ("y", `Y); ("x", `X) ] in 9 | (parser, printer) 10 | 11 | let target_serialize ppf = function 12 | | `Y -> Fmt.pf ppf "`Y" 13 | | `X -> Fmt.pf ppf "`X" 14 | 15 | let target = 16 | let conv' = 17 | Key.Arg.conv ~conv:target_conv ~runtime_conv:"target" 18 | ~serialize:target_serialize 19 | in 20 | let doc = Key.Arg.info ~doc:"Target." [ "t" ] in 21 | Key.(create "target" Arg.(opt conv' `X doc)) 22 | 23 | let main = match_impl (Key.value target) ~default:y [ (`X, x) ] 24 | let () = register ~src:`None "noop" [ main ] 25 | -------------------------------------------------------------------------------- /test/mirage/random-unix/test.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let test () = 4 | let context = Key.add_to_context Key.target `Unix Key.empty_context in 5 | let sigs = conduit @-> random @-> job in 6 | let network = default_network in 7 | let etif = etif network in 8 | let arp = arp etif in 9 | let ipv4 = create_ipv4 etif arp in 10 | let ipv6 = create_ipv6 network etif in 11 | let stackv4v6 = 12 | direct_stackv4v6 ~ipv4_only:(Key.ipv4_only ()) ~ipv6_only:(Key.ipv6_only ()) 13 | network etif arp ipv4 ipv6 14 | in 15 | let job = 16 | main "App.Make" sigs $ conduit_direct ~tls:true stackv4v6 $ default_random 17 | in 18 | Functoria_test.run context job 19 | 20 | let () = 21 | match Functoria.Action.run (test ()) with 22 | | Ok () -> () 23 | | Error (`Msg e) -> failwith e 24 | -------------------------------------------------------------------------------- /test/functoria-test/functoria_test.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Action.Syntax 3 | 4 | let prelude i = 5 | Action.with_output ~path:(Info.main i) ~purpose:"init tests" @@ fun ppf -> 6 | Fmt.pf ppf 7 | {|(* Geneated by functoria_test *) 8 | 9 | let (>>=) x f = f x 10 | let return x = x 11 | let run x = x 12 | 13 | |} 14 | 15 | let run ?(keys = []) ?init context device = 16 | let t = Impl.abstract device in 17 | let keys = keys @ Key.Set.elements (Engine.all_keys t) in 18 | let packages = Key.eval context (Engine.packages t) in 19 | let info = 20 | Functoria.Info.v ~packages ~context ~keys ~build_cmd:"build me" ~src:`None 21 | "foo" 22 | in 23 | let t = Impl.eval ~context t in 24 | let* () = prelude info in 25 | let* () = Engine.configure info t in 26 | Engine.connect ?init info t 27 | -------------------------------------------------------------------------------- /test/opam-monorepo/unikernel.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "noop" 3 | maintainer: "dummy" 4 | authors: "dummy" 5 | homepage: "dummy" 6 | bug-reports: "dummy" 7 | dev-repo: "git://dummy" 8 | synopsis: "Unikernel noop - switch dependencies" 9 | description: """ 10 | It assumes that local dependencies are already 11 | fetched. 12 | """ 13 | 14 | build: [ 15 | [ "test" "configure" ] 16 | [ "test" "build" ] 17 | ] 18 | 19 | install: [ 20 | [ "cp" "dist/f0.exe" "%{bin}%/f0" ] 21 | ] 22 | 23 | depends: [ 24 | "ocaml-solo5" 25 | "mirage-runtime" 26 | "fmt" 27 | "zarith" 28 | ] 29 | 30 | x-opam-monorepo-opam-provided: [ "ocaml-solo5" ] 31 | 32 | x-opam-monorepo-opam-repositories: [ 33 | "file://$OPAM_MONOREPO_CWD/mini-opam-overlays" 34 | "file://$OPAM_MONOREPO_CWD/mini-opam-repository" 35 | ] 36 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_tcp.mli: -------------------------------------------------------------------------------- 1 | type 'a tcp 2 | 3 | val tcp : 'a tcp Functoria.typ 4 | 5 | type tcpv4v6 = Mirage_impl_ip.v4v6 tcp 6 | 7 | val tcpv4v6 : tcpv4v6 Functoria.typ 8 | 9 | val direct_tcp : 10 | ?mclock:Mirage_impl_mclock.mclock Functoria.impl -> 11 | ?time:Mirage_impl_time.time Functoria.impl -> 12 | ?random:Mirage_impl_random.random Functoria.impl -> 13 | 'a Mirage_impl_ip.ip Functoria.impl -> 14 | 'a tcp Functoria.impl 15 | 16 | val socket_tcpv4v6 : 17 | ?group:string -> 18 | Ipaddr.V4.t option -> 19 | Ipaddr.V6.t option -> 20 | tcpv4v6 Functoria.impl 21 | 22 | val tcpv4v6_socket_conf : 23 | ipv4_only:bool Mirage_key.key -> 24 | ipv6_only:bool Mirage_key.key -> 25 | Ipaddr.V4.Prefix.t Mirage_key.key -> 26 | Ipaddr.V6.Prefix.t option Mirage_key.key -> 27 | tcpv4v6 Functoria.impl 28 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_time.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Key = Mirage_key 3 | 4 | type time = TIME 5 | 6 | let time = Type.v TIME 7 | 8 | let default_time = 9 | let unix_time = 10 | impl ~packages:[ package "mirage-time" ] "Unix_os.Time" time 11 | in 12 | let solo5_time = 13 | impl ~packages:[ package "mirage-time" ] "Solo5_os.Time" time 14 | in 15 | let xen_time = impl ~packages:[ package "mirage-time" ] "Xen_os.Time" time in 16 | match_impl 17 | Key.(value target) 18 | [ 19 | (`Unix, unix_time); 20 | (`MacOSX, unix_time); 21 | (`Xen, xen_time); 22 | (`Qubes, xen_time); 23 | (`Virtio, solo5_time); 24 | (`Hvt, solo5_time); 25 | (`Spt, solo5_time); 26 | (`Muen, solo5_time); 27 | (`Genode, solo5_time); 28 | ] 29 | ~default:unix_time 30 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_random.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_mclock 3 | open Mirage_impl_time 4 | 5 | type random = RANDOM 6 | 7 | let random = Type.v RANDOM 8 | 9 | let rng ?(time = default_time) ?(mclock = default_monotonic_clock) () = 10 | let packages = 11 | [ 12 | package ~min:"0.8.0" ~max:"0.11.0" "mirage-crypto-rng-mirage"; 13 | package ~min:"3.0.0" ~max:"4.0.0" "mirage-random"; 14 | ] 15 | in 16 | let connect _ modname _ = 17 | (* here we could use the boot argument (--prng) to select the RNG! *) 18 | Fmt.str "%s.initialize (module Mirage_crypto_rng.Fortuna)" modname 19 | in 20 | impl ~packages ~connect "Mirage_crypto_rng_mirage.Make" 21 | (Mirage_impl_time.time @-> Mirage_impl_mclock.mclock @-> random) 22 | $ time 23 | $ mclock 24 | 25 | let default_random = rng () 26 | -------------------------------------------------------------------------------- /test/mirage/random-xen/test.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let test () = 4 | let context = Key.add_to_context Key.target `Xen Key.empty_context in 5 | let keys = [ Key.v Mirage.Key.target ] in 6 | let sigs = conduit @-> random @-> job in 7 | let network = default_network in 8 | let etif = etif network in 9 | let arp = arp etif in 10 | let ipv4 = create_ipv4 etif arp in 11 | let ipv6 = create_ipv6 network etif in 12 | let stackv4v6 = 13 | direct_stackv4v6 ~ipv4_only:(Key.ipv4_only ()) ~ipv6_only:(Key.ipv6_only ()) 14 | network etif arp ipv4 ipv6 15 | in 16 | let job = 17 | main "App.Make" sigs $ conduit_direct ~tls:true stackv4v6 $ default_random 18 | in 19 | Functoria_test.run ~keys context job 20 | 21 | let () = 22 | match Functoria.Action.run (test ()) with 23 | | Ok () -> () 24 | | Error (`Msg e) -> failwith e 25 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ISC License 2 | 3 | Copyright (X) 2011-2018, the [MirageOS contributors](https://mirage.io/community/#team) 4 | 5 | Permission to use, copy, modify, and distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | -------------------------------------------------------------------------------- /test/functoria/gen-1/test.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | 3 | let build_info = 4 | [ 5 | ("base-bigarray", "base"); 6 | ("base-threads", "base"); 7 | ("base-unix", "base"); 8 | ("cmdliner", "1.0.4"); 9 | ("conf-m4", "1"); 10 | ("dune", "2.0.0"); 11 | ("fmt", "0.8.8"); 12 | ("ocaml", "4.08.1"); 13 | ("ocaml-base-compiler", "4.08.1"); 14 | ("ocaml-config", "1"); 15 | ("ocamlbuild", "0.14.0"); 16 | ("ocamlfind", "1.8.1"); 17 | ("seq", "base"); 18 | ("stdlib-shims", "0.1.0"); 19 | ("topkg", "1.0.1"); 20 | ] 21 | 22 | let test () = 23 | let context = Key.empty_context in 24 | let sigs = job @-> info @-> job in 25 | let job = main "App.Make" sigs $ keys sys_argv $ app_info ~build_info () in 26 | Functoria_test.run context job 27 | 28 | let () = 29 | match Action.run (test ()) with Ok () -> () | Error (`Msg e) -> failwith e 30 | -------------------------------------------------------------------------------- /bin/main.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let () = Mirage.Tool.run () 18 | -------------------------------------------------------------------------------- /test/functoria/gen-1/main.ml.expected: -------------------------------------------------------------------------------- 1 | (* Geneated by functoria_test *) 2 | 3 | let (>>=) x f = f x 4 | let return x = x 5 | let run x = x 6 | 7 | module App_make__4 = App.Make(Key_gen)(Info_gen) 8 | 9 | let sys__1 = lazy ( 10 | return Sys.argv 11 | ) 12 | 13 | let key_gen__2 = lazy ( 14 | let __sys__1 = Lazy.force sys__1 in 15 | __sys__1 >>= fun _sys__1 -> 16 | return (Functoria_runtime.with_argv (List.map fst Key_gen.runtime_keys) "foo" _sys__1) 17 | ) 18 | 19 | let info_gen__3 = lazy ( 20 | return Info_gen.info 21 | ) 22 | 23 | let app_make__4 = lazy ( 24 | let __key_gen__2 = Lazy.force key_gen__2 in 25 | let __info_gen__3 = Lazy.force info_gen__3 in 26 | __key_gen__2 >>= fun _key_gen__2 -> 27 | __info_gen__3 >>= fun _info_gen__3 -> 28 | App_make__4.start _key_gen__2 _info_gen__3 29 | ) 30 | 31 | let () = 32 | let t = 33 | Lazy.force app_make__4 34 | in run t 35 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_http.mli: -------------------------------------------------------------------------------- 1 | open Functoria 2 | 3 | type http 4 | 5 | val http : http typ 6 | val cohttp_server : Mirage_impl_conduit.conduit impl -> http impl 7 | val httpaf_server : Mirage_impl_conduit.conduit impl -> http impl 8 | 9 | type http_client 10 | 11 | val http_client : http_client typ 12 | 13 | val cohttp_client : 14 | ?pclock:Mirage_impl_pclock.pclock impl -> 15 | Mirage_impl_resolver.resolver impl -> 16 | Mirage_impl_conduit.conduit impl -> 17 | http_client impl 18 | 19 | type http_server 20 | 21 | val http_server : http_server typ 22 | 23 | val paf_server : 24 | int Mirage_key.key -> (Mirage_impl_tcp.tcpv4v6 -> http_server) impl 25 | 26 | type alpn_client 27 | 28 | val alpn_client : alpn_client typ 29 | 30 | val paf_client : 31 | (Mirage_impl_pclock.pclock -> 32 | Mirage_impl_tcp.tcpv4v6 -> 33 | Mirage_impl_mimic.mimic -> 34 | alpn_client) 35 | impl 36 | -------------------------------------------------------------------------------- /test/mirage/info_gen/main.ml.expected: -------------------------------------------------------------------------------- 1 | (* Geneated by functoria_test *) 2 | 3 | let (>>=) x f = f x 4 | let return x = x 5 | let run x = x 6 | 7 | module App_make__4 = App.Make(Key_gen)(Info_gen) 8 | 9 | let bootvar__1 = lazy ( 10 | Bootvar.argv () 11 | ) 12 | 13 | let key_gen__2 = lazy ( 14 | let __bootvar__1 = Lazy.force bootvar__1 in 15 | __bootvar__1 >>= fun _bootvar__1 -> 16 | return (Mirage_runtime.with_argv (List.map fst Key_gen.runtime_keys) "foo" _bootvar__1) 17 | ) 18 | 19 | let info_gen__3 = lazy ( 20 | return Info_gen.info 21 | ) 22 | 23 | let app_make__4 = lazy ( 24 | let __key_gen__2 = Lazy.force key_gen__2 in 25 | let __info_gen__3 = Lazy.force info_gen__3 in 26 | __key_gen__2 >>= fun _key_gen__2 -> 27 | __info_gen__3 >>= fun _info_gen__3 -> 28 | App_make__4.start _key_gen__2 _info_gen__3 29 | ) 30 | 31 | let () = 32 | let t = 33 | Lazy.force app_make__4 34 | in run t 35 | -------------------------------------------------------------------------------- /test/functoria/e2e/test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Jeremy Yallop 3 | * Copyright (c) 2021 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | let () = E2e.run () 19 | -------------------------------------------------------------------------------- /test/mirage/action/test.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let context_singleton key value = 4 | let info = Cmdliner.Cmd.info "" in 5 | let term = 6 | Key.context ~with_required:false (Key.Set.singleton @@ Key.v key) 7 | in 8 | let argv = [| "mirage"; "--target"; value |] in 9 | match Cmdliner.Cmd.eval_value ~argv (Cmdliner.Cmd.v info term) with 10 | | Ok (`Ok x) -> x 11 | | _ -> assert false 12 | 13 | let print_banner s = 14 | print_endline s; 15 | print_endline @@ String.make (String.length s) '='; 16 | print_newline () 17 | 18 | let info context = 19 | Info.v ~packages:[] ~keys:[] ~build_cmd:"mirage build" ~context ~src:`None 20 | "NAME" 21 | 22 | let test target = 23 | print_banner target; 24 | let context = context_singleton Key.target target in 25 | let env = Action.env ~files:(`Files []) () in 26 | Action.dry_run_trace ~env @@ Project.configure @@ info context; 27 | print_newline () 28 | 29 | let () = List.iter test [ "unix"; "hvt" ] 30 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_mimic.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_dns 3 | open Mirage_impl_stack 4 | open Mirage_impl_happy_eyeballs 5 | 6 | type mimic = Mimic 7 | 8 | let mimic = Type.v Mimic 9 | 10 | let mimic_merge = 11 | let packages = [ package "mimic" ] in 12 | let connect _ _modname = function 13 | | [ a; b ] -> Fmt.str "Lwt.return (Mimic.merge %s %s)" a b 14 | | [ x ] -> Fmt.str "%s.ctx" x 15 | | _ -> Fmt.str "Lwt.return Mimic.empty" 16 | in 17 | impl ~packages ~connect "Mimic.Merge" (mimic @-> mimic @-> mimic) 18 | 19 | let mimic_happy_eyeballs = 20 | let packages = [ package "mimic-happy-eyeballs" ~min:"0.0.5" ] in 21 | let connect _ modname = function 22 | | [ _stackv4v6; _dns_client; happy_eyeballs ] -> 23 | Fmt.str {ocaml|%s.connect %s|ocaml} modname happy_eyeballs 24 | | _ -> assert false 25 | in 26 | impl ~packages ~connect "Mimic_happy_eyeballs.Make" 27 | (stackv4v6 @-> dns_client @-> happy_eyeballs @-> mimic) 28 | -------------------------------------------------------------------------------- /lib/mirage/target/s.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Key = Mirage_key 3 | 4 | (** A Mirage target: target consists in multiple backends grouped together. *) 5 | module type TARGET = sig 6 | type t 7 | (** The type representing a specific backend in a target. *) 8 | 9 | val cast : Key.mode -> t 10 | (** Ensures the mode is a backend supported by this target. *) 11 | 12 | val dune : Info.t -> Dune.stanza list 13 | (** Dune rules to build the unikernel *) 14 | 15 | val configure : Info.t -> unit Action.t 16 | (** Configure-time actions. *) 17 | 18 | val build_context : ?build_dir:Fpath.t -> Info.t -> Dune.stanza list 19 | (** Generate build context configuration *) 20 | 21 | val context_name : Info.t -> string 22 | (** Dune context *) 23 | 24 | val packages : t -> package list 25 | (** The required packages to support this backend. *) 26 | 27 | val install : Info.t -> Install.t 28 | (** [install i] returns which files are installed in context [i]. *) 29 | end 30 | -------------------------------------------------------------------------------- /functoria-runtime.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Gabriel Radanne " 3 | authors: [ "Thomas Gazagnaire" 4 | "Anil Madhavapeddy" 5 | "Dave Scott" 6 | "Thomas Leonard" 7 | "Gabriel Radanne" ] 8 | homepage: "https://github.com/mirage/mirage" 9 | bug-reports: "https://github.com/mirage/mirage/issues" 10 | dev-repo: "git+https://github.com/mirage/mirage.git" 11 | doc: "https://mirage.github.io/mirage/" 12 | license: "ISC" 13 | tags: ["org:mirage"] 14 | 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | ["dune" "build" "-p" name "-j" jobs] 18 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 19 | ] 20 | 21 | depends: [ 22 | "ocaml" {>= "4.08.0"} 23 | "dune" {>= "2.9.0"} 24 | "cmdliner" {>= "1.1.0"} 25 | "fmt" {>= "0.8.7"} 26 | ] 27 | 28 | synopsis: "Runtime support library for functoria-generated code" 29 | description: """ 30 | This is the runtime support library for code generated by functoria. 31 | """ 32 | -------------------------------------------------------------------------------- /lib/mirage/target/mirage_target.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Key = Mirage_key 3 | 4 | let choose : Key.mode -> (module S.TARGET) = function 5 | | #Solo5.t -> (module Solo5) 6 | | #Unix.t -> (module Unix) 7 | 8 | let dune i = 9 | let target = Info.get i Key.target in 10 | let (module Target) = choose target in 11 | Target.dune i 12 | 13 | let configure i = 14 | let target = Info.get i Key.target in 15 | let (module Target) = choose target in 16 | Target.configure i 17 | 18 | let build_context ?build_dir i = 19 | let target = Info.get i Key.target in 20 | let (module Target) = choose target in 21 | Target.build_context ?build_dir i 22 | 23 | let context_name i = 24 | let target = Info.get i Key.target in 25 | let (module Target) = choose target in 26 | Target.context_name i 27 | 28 | let packages target = 29 | let (module Target) = choose target in 30 | Target.(packages (cast target)) 31 | 32 | let install i = 33 | let target = Info.get i Key.target in 34 | let (module Target) = choose target in 35 | Target.install i 36 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_conduit.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_stack 3 | open Mirage_impl_misc 4 | open Mirage_impl_random 5 | 6 | type conduit = Conduit 7 | 8 | let conduit = Type.v Conduit 9 | let pkg = package ~min:"6.0.1" ~max:"7.0.0" "conduit-mirage" 10 | 11 | let tcp = 12 | let packages = [ pkg ] in 13 | let connect _ _ = function 14 | | [ stack ] -> Fmt.str "Lwt.return %s@;" stack 15 | | _ -> failwith (connect_err "tcp_conduit" 1) 16 | in 17 | impl ~packages ~connect "Conduit_mirage.TCP" (stackv4v6 @-> conduit) 18 | 19 | let tls random = 20 | let packages = [ pkg; package ~min:"0.13.0" ~max:"0.16.0" "tls-mirage" ] in 21 | let extra_deps = [ dep random ] in 22 | let connect _ _ = function 23 | | [ stack; _random ] -> Fmt.str "Lwt.return %s@;" stack 24 | | _ -> failwith (connect_err "tls_conduit" 1) 25 | in 26 | impl ~packages ~connect ~extra_deps "Conduit_mirage.TLS" (conduit @-> conduit) 27 | 28 | let conduit_direct ?tls:(use_tls = false) ?(random = default_random) s = 29 | if use_tls then tls random $ (tcp $ s) else tcp $ s 30 | -------------------------------------------------------------------------------- /test/functoria/gen-2/main.ml.expected: -------------------------------------------------------------------------------- 1 | (* Geneated by functoria_test *) 2 | 3 | let (>>=) x f = f x 4 | let return x = x 5 | let run x = x 6 | 7 | module App_make__5 = App.Make(Key_gen)(Unit)(Info_gen) 8 | 9 | let sys__1 = lazy ( 10 | return Sys.argv 11 | ) 12 | 13 | let key_gen__2 = lazy ( 14 | let __sys__1 = Lazy.force sys__1 in 15 | __sys__1 >>= fun _sys__1 -> 16 | return (Functoria_runtime.with_argv (List.map fst Key_gen.runtime_keys) "foo" _sys__1) 17 | ) 18 | 19 | let unit__3 = lazy ( 20 | return () 21 | ) 22 | 23 | let info_gen__4 = lazy ( 24 | return Info_gen.info 25 | ) 26 | 27 | let app_make__5 = lazy ( 28 | let __key_gen__2 = Lazy.force key_gen__2 in 29 | let __unit__3 = Lazy.force unit__3 in 30 | let __info_gen__4 = Lazy.force info_gen__4 in 31 | __key_gen__2 >>= fun _key_gen__2 -> 32 | __unit__3 >>= fun _unit__3 -> 33 | __info_gen__4 >>= fun _info_gen__4 -> 34 | App_make__5.start _key_gen__2 _unit__3 _info_gen__4 35 | ) 36 | 37 | let () = 38 | let t = 39 | Lazy.force key_gen__2 >>= fun _ -> 40 | Lazy.force unit__3 >>= fun _ -> 41 | Lazy.force app_make__5 42 | in run t 43 | -------------------------------------------------------------------------------- /test/functoria/gen-2/test.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | 3 | let build_info = 4 | [ 5 | ("base-bigarray", "base"); 6 | ("base-threads", "base"); 7 | ("base-unix", "base"); 8 | ("cmdliner", "1.0.4"); 9 | ("conf-m4", "1"); 10 | ("dune", "2.0.0"); 11 | ("fmt", "0.8.8"); 12 | ("ocaml", "4.08.1"); 13 | ("ocaml-base-compiler", "4.08.1"); 14 | ("ocaml-config", "1"); 15 | ("ocamlbuild", "0.14.0"); 16 | ("ocamlfind", "1.8.1"); 17 | ("seq", "base"); 18 | ("stdlib-shims", "0.1.0"); 19 | ("topkg", "1.0.1"); 20 | ] 21 | 22 | let key = 23 | let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in 24 | Key.(create "hello" Arg.(opt string "Hello World!" doc)) 25 | 26 | let test () = 27 | let i1 = keys sys_argv in 28 | let i2 = noop in 29 | let context = Key.empty_context in 30 | let sigs = job @-> job @-> info @-> job in 31 | let job = 32 | main ~keys:[ Key.v key ] "App.Make" sigs $ i1 $ i2 $ app_info ~build_info () 33 | in 34 | Functoria_test.run ~init:[ i1; i2 ] context job 35 | 36 | let () = 37 | match Action.run (test ()) with Ok () -> () | Error (`Msg e) -> failwith e 38 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_argv.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Key = Mirage_key 3 | 4 | let ty = Functoria.argv 5 | 6 | let argv_unix = 7 | let packages = [ package ~min:"0.1.0" ~max:"0.2.0" "mirage-bootvar-unix" ] in 8 | let connect _ _ _ = "Bootvar.argv ()" in 9 | impl ~packages ~connect "Bootvar" ty 10 | 11 | let argv_solo5 = 12 | let packages = [ package ~min:"0.6.0" ~max:"0.7.0" "mirage-bootvar-solo5" ] in 13 | let connect _ _ _ = "Bootvar.argv ()" in 14 | impl ~packages ~connect "Bootvar" ty 15 | 16 | let no_argv = 17 | let connect _ _ _ = "return [|\"\"|]" in 18 | impl ~connect "Mirage_runtime" ty 19 | 20 | let argv_xen = 21 | let packages = [ package ~min:"0.8.0" ~max:"0.9.0" "mirage-bootvar-xen" ] in 22 | let connect _ _ _ = "Bootvar.argv ()" in 23 | impl ~packages ~connect "Bootvar" ty 24 | 25 | let default_argv = 26 | match_impl 27 | Key.(value target) 28 | [ 29 | (`Xen, argv_xen); 30 | (`Qubes, argv_xen); 31 | (`Virtio, argv_solo5); 32 | (`Hvt, argv_solo5); 33 | (`Muen, argv_solo5); 34 | (`Genode, argv_solo5); 35 | (`Spt, argv_solo5); 36 | ] 37 | ~default:argv_unix 38 | -------------------------------------------------------------------------------- /lib/functoria/argv.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type t = ARGV 20 | 21 | let argv = Type.v ARGV 22 | 23 | let sys_argv = 24 | let connect _ _ _ = "return Sys.argv" in 25 | Impl.v ~connect "Sys" argv 26 | -------------------------------------------------------------------------------- /test/functoria/e2e/describe.t: -------------------------------------------------------------------------------- 1 | Test that `describe` works as expected: 2 | 3 | $ ./test.exe describe --file app/config.ml 4 | Name noop 5 | Keys 6 | hello=Hello World! (default), 7 | vote=cat (default), 8 | warn_error=false (default) 9 | $ ./test.exe describe -v --file app/config.ml 10 | test.exe: [INFO] run: describe: 11 | { "args" = 12 | { "context" = ; 13 | "config_file" = app/config.ml; 14 | "output" = None; 15 | "dry_run" = false }; 16 | "dotcmd" = "xdot"; 17 | "dot" = false; 18 | "eval" = None } 19 | test.exe: [INFO] Generating: app/test/dune-workspace.config (base) 20 | test.exe: [INFO] Generating: dune-project (base) 21 | test.exe: [INFO] Generating: app/dune.config (base) 22 | Name noop 23 | Keys 24 | hello=Hello World! (default), 25 | vote=cat (default), 26 | warn_error=false (default)Libraries fmt, functoria-runtime 27 | Packages fmt { ?monorepo }, functoria-runtime { ?monorepo } 28 | -------------------------------------------------------------------------------- /test/mirage/help/gen.ml: -------------------------------------------------------------------------------- 1 | type t = { file : string; cmd : string } 2 | 3 | let v x = { file = x; cmd = x } 4 | 5 | let gen t = 6 | Format.printf 7 | {| 8 | (rule 9 | (target help-%s) 10 | (action 11 | (with-stdout-to 12 | %%{target} 13 | (setenv MIRAGE_DEFAULT_TARGET unix 14 | (run ./config.exe help %s --man-format=plain))))) 15 | 16 | (rule 17 | (target %s-help) 18 | (action 19 | (with-stdout-to 20 | %%{target} 21 | (setenv MIRAGE_DEFAULT_TARGET unix 22 | (run ./config.exe %s --help=plain))))) 23 | 24 | (rule 25 | (alias runtest) 26 | (package mirage) 27 | (action 28 | (diff help-%s.expected help-%s))) 29 | 30 | (rule 31 | (alias runtest) 32 | (package mirage) 33 | (action 34 | (diff %s-help.expected %s-help))) 35 | 36 | (rule 37 | (alias runtest) 38 | (package mirage) 39 | (action 40 | (diff %s-help help-%s))) 41 | |} 42 | t.file t.cmd t.file t.cmd t.file t.file t.file t.file t.file t.file 43 | 44 | let () = 45 | List.iter gen 46 | [ 47 | v "configure"; 48 | { file = "configure-o"; cmd = "configure -o foo" }; 49 | v "build"; 50 | v "clean"; 51 | v "query"; 52 | v "describe"; 53 | ] 54 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_syslog.mli: -------------------------------------------------------------------------------- 1 | type syslog 2 | 3 | val syslog : syslog Functoria.typ 4 | 5 | type syslog_config = { 6 | hostname : string; 7 | server : Ipaddr.t option; 8 | port : int option; 9 | truncate : int option; 10 | } 11 | 12 | val syslog_config : 13 | ?port:int -> ?truncate:int -> ?server:Ipaddr.t -> string -> syslog_config 14 | 15 | val syslog_udp : 16 | ?config:syslog_config -> 17 | ?console:Mirage_impl_console.console Functoria.impl -> 18 | ?clock:Mirage_impl_pclock.pclock Functoria.impl -> 19 | Mirage_impl_stack.stackv4v6 Functoria.impl -> 20 | syslog Functoria.impl 21 | 22 | val syslog_tcp : 23 | ?config:syslog_config -> 24 | ?console:Mirage_impl_console.console Functoria.impl -> 25 | ?clock:Mirage_impl_pclock.pclock Functoria.impl -> 26 | Mirage_impl_stack.stackv4v6 Functoria.impl -> 27 | syslog Functoria.impl 28 | 29 | val syslog_tls : 30 | ?config:syslog_config -> 31 | ?keyname:string -> 32 | ?console:Mirage_impl_console.console Functoria.impl -> 33 | ?clock:Mirage_impl_pclock.pclock Functoria.impl -> 34 | Mirage_impl_stack.stackv4v6 Functoria.impl -> 35 | Mirage_impl_kv.ro Functoria.impl -> 36 | syslog Functoria.impl 37 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_console.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Key = Mirage_key 3 | 4 | type console = CONSOLE 5 | 6 | let console = Type.v CONSOLE 7 | let connect str _ m _ = Fmt.str "%s.connect %S" m str 8 | 9 | let console_unix str = 10 | let packages = [ package ~min:"5.1.0" ~max:"6.0.0" "mirage-console-unix" ] in 11 | impl ~packages ~connect:(connect str) "Console_unix" console 12 | 13 | let console_xen str = 14 | let packages = [ package ~min:"5.1.0" ~max:"6.0.0" "mirage-console-xen" ] in 15 | impl ~packages ~connect:(connect str) "Console_xen" console 16 | 17 | let console_solo5 str = 18 | let packages = [ package ~min:"0.8.0" ~max:"0.9.0" "mirage-console-solo5" ] in 19 | impl ~packages ~connect:(connect str) "Console_solo5" console 20 | 21 | let custom_console str = 22 | match_impl 23 | Key.(value target) 24 | [ 25 | (`Xen, console_xen str); 26 | (`Qubes, console_xen str); 27 | (`Virtio, console_solo5 str); 28 | (`Hvt, console_solo5 str); 29 | (`Spt, console_solo5 str); 30 | (`Muen, console_solo5 str); 31 | (`Genode, console_solo5 str); 32 | ] 33 | ~default:(console_unix str) 34 | 35 | let default_console = custom_console "0" 36 | -------------------------------------------------------------------------------- /lib/functoria/makefile.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type t 20 | 21 | val v : 22 | ?extra_repo:(string * string) list -> 23 | build_dir:Fpath.t -> 24 | builder_name:string -> 25 | depext:bool -> 26 | Misc.Name.Opam.t -> 27 | t 28 | 29 | val pp : t Fmt.t 30 | -------------------------------------------------------------------------------- /mirage-runtime.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: ["anil@recoil.org" "thomas@gazagnaire.org"] 3 | authors: ["Thomas Gazagnaire" "Anil Madhavapeddy" "Gabriel Radanne" 4 | "Mindy Preston" "Thomas Leonard" "Nicolas Ojeda Bar" 5 | "Dave Scott" "David Kaloper" "Hannes Mehnert" "Richard Mortier"] 6 | homepage: "https://github.com/mirage/mirage" 7 | bug-reports: "https://github.com/mirage/mirage/issues/" 8 | dev-repo: "git+https://github.com/mirage/mirage.git" 9 | license: "ISC" 10 | tags: ["org:mirage" "org:xapi-project"] 11 | doc: "https://mirage.github.io/mirage/" 12 | 13 | build: [ 14 | ["dune" "subst"] {dev} 15 | ["dune" "build" "-p" name "-j" jobs] 16 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 17 | ] 18 | 19 | depends: [ 20 | "ocaml" {>= "4.08.0"} 21 | "dune" {>= "2.9.0"} 22 | "ipaddr" {>= "5.0.0"} 23 | "functoria-runtime" {= version} 24 | "fmt" {>= "0.8.4"} 25 | "logs" 26 | "lwt" {>= "4.0.0"} 27 | "alcotest" {with-test} 28 | ] 29 | conflicts: [ "result" {< "1.5"} ] 30 | synopsis: "The base MirageOS runtime library, part of every MirageOS unikernel" 31 | description: """ 32 | A bundle of useful runtime functions for applications built with MirageOS 33 | """ 34 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_block.mli: -------------------------------------------------------------------------------- 1 | type block 2 | 3 | val block : block Functoria.typ 4 | 5 | val generic_block : 6 | ?group:string -> 7 | ?key:[ `BlockFile | `Ramdisk | `XenstoreId ] Functoria.value -> 8 | string -> 9 | block Functoria.impl 10 | 11 | val archive : block Functoria.impl -> Mirage_impl_kv.ro Functoria.impl 12 | val fat_ro : block Functoria.impl -> Mirage_impl_kv.ro Functoria.impl 13 | val ramdisk : string -> block Functoria.impl 14 | val block_of_xenstore_id : string -> block Functoria.impl 15 | val block_of_file : string -> block Functoria.impl 16 | val block_conf : string -> block Functoria.device 17 | 18 | val docteur : 19 | ?mode:[ `Fast | `Light ] -> 20 | ?disk:string Functoria.Key.key -> 21 | ?analyze:bool Functoria.Key.key -> 22 | ?branch:string -> 23 | ?extra_deps:string list -> 24 | string -> 25 | Mirage_impl_kv.ro Functoria.impl 26 | 27 | type block_t = { filename : string; number : int } 28 | 29 | val all_blocks : (string, block_t) Hashtbl.t 30 | 31 | val chamelon : 32 | program_block_size:int Functoria.key -> 33 | (block -> Mirage_impl_pclock.pclock -> Mirage_impl_kv.rw) Functoria.impl 34 | 35 | val ccm_block : 36 | ?maclen:int -> 37 | ?nonce_len:int -> 38 | string option Functoria.key -> 39 | (block -> block) Functoria.impl 40 | -------------------------------------------------------------------------------- /lib/functoria/filegen.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Basic helpers to generate files. *) 20 | 21 | module type PROJECT = sig 22 | val name : string 23 | val version : string 24 | end 25 | 26 | module Make (P : PROJECT) : sig 27 | val write : Fpath.t -> string -> unit Action.t 28 | val headers : [ `OCaml | `Sexp | `Make | `Opam ] -> string 29 | val rm : Fpath.t -> unit Action.t 30 | end 31 | -------------------------------------------------------------------------------- /lib/functoria/argv.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Device representing the command line. *) 20 | 21 | type t 22 | (** The type for command-line arguments, similar to the usual [Sys.argv]. *) 23 | 24 | val argv : t Type.t 25 | (** [argv] is a value representing {!argv} module types. *) 26 | 27 | val sys_argv : t Impl.t 28 | (** [sys_argv] is a device providing command-line arguments by using 29 | {!Sys.argv}. *) 30 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_stack.mli: -------------------------------------------------------------------------------- 1 | type stackv4v6 2 | 3 | val stackv4v6 : stackv4v6 Functoria.typ 4 | 5 | val direct_stackv4v6 : 6 | ?mclock:Mirage_impl_mclock.mclock Functoria.impl -> 7 | ?random:Mirage_impl_random.random Functoria.impl -> 8 | ?time:Mirage_impl_time.time Functoria.impl -> 9 | ipv4_only:bool Mirage_key.key -> 10 | ipv6_only:bool Mirage_key.key -> 11 | Mirage_impl_network.network Functoria.impl -> 12 | Mirage_impl_ethernet.ethernet Functoria.impl -> 13 | Mirage_impl_arpv4.arpv4 Functoria.impl -> 14 | Mirage_impl_ip.ipv4 Functoria.impl -> 15 | Mirage_impl_ip.ipv6 Functoria.impl -> 16 | stackv4v6 Functoria.impl 17 | 18 | val socket_stackv4v6 : ?group:string -> unit -> stackv4v6 Functoria.impl 19 | 20 | val static_ipv4v6_stack : 21 | ?group:string -> 22 | ?ipv6_config:Mirage_impl_ip.ipv6_config -> 23 | ?ipv4_config:Mirage_impl_ip.ipv4_config -> 24 | ?arp: 25 | (Mirage_impl_ethernet.ethernet Functoria.impl -> 26 | Mirage_impl_arpv4.arpv4 Functoria.impl) -> 27 | Mirage_impl_network.network Functoria.impl -> 28 | stackv4v6 Functoria.impl 29 | 30 | val generic_stackv4v6 : 31 | ?group:string -> 32 | ?ipv6_config:Mirage_impl_ip.ipv6_config -> 33 | ?ipv4_config:Mirage_impl_ip.ipv4_config -> 34 | ?dhcp_key:bool Functoria.value -> 35 | ?net_key:[ `Direct | `Socket ] option Functoria.value -> 36 | Mirage_impl_network.network Functoria.impl -> 37 | stackv4v6 Functoria.impl 38 | -------------------------------------------------------------------------------- /lib/functoria/opam.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type t 20 | 21 | val v : 22 | ?configure:string -> 23 | ?pre_build:(Fpath.t option -> string) -> 24 | ?lock_location:(Fpath.t option -> string -> string) -> 25 | ?build:string -> 26 | ?install:Install.t -> 27 | ?extra_repo:(string * string) list -> 28 | ?depends:Package.t list -> 29 | ?pins:(string * string) list -> 30 | ?subdir:Fpath.t -> 31 | src:[ `Auto | `None | `Some of string ] -> 32 | opam_name:string -> 33 | string -> 34 | t 35 | 36 | val pp : t Fmt.t 37 | -------------------------------------------------------------------------------- /lib/functoria/misc.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Utility module. *) 20 | 21 | (** {2 Misc} *) 22 | 23 | open Rresult 24 | 25 | val err_cmdliner : ?usage:bool -> ('a, string) result -> 'a Cmdliner.Term.ret 26 | 27 | module type Monoid = sig 28 | type t 29 | 30 | val empty : t 31 | val union : t -> t -> t 32 | end 33 | 34 | module Name : sig 35 | module Opam : sig 36 | type t 37 | 38 | val to_string : t -> string 39 | end 40 | 41 | val opamify : string -> Opam.t 42 | val ocamlify : string -> string 43 | end 44 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_dns.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_time 3 | open Mirage_impl_mclock 4 | open Mirage_impl_pclock 5 | open Mirage_impl_stack 6 | open Mirage_impl_random 7 | 8 | type dns_client = Dns_client 9 | 10 | let dns_client = Type.v Dns_client 11 | 12 | let generic_dns_client timeout nameservers = 13 | let packages = 14 | [ package "dns-client" ~sublibs:[ "mirage" ] ~min:"6.2.0" ~max:"7.0.0" ] 15 | in 16 | let keys = 17 | match (nameservers, timeout) with 18 | | None, None -> [] 19 | | None, Some timeout -> [ Key.v timeout ] 20 | | Some nameservers, None -> [ Key.v nameservers ] 21 | | Some nameservers, Some timeout -> [ Key.v nameservers; Key.v timeout ] 22 | in 23 | let connect _info modname = function 24 | | [ _random; _time; _mclock; _pclock; stackv4v6 ] -> 25 | let pp_nameservers ppf = function 26 | | None -> Fmt.string ppf "[]" 27 | | Some nameservers -> Key.serialize_call ppf (Key.v nameservers) 28 | in 29 | let pp_timeout ppf = function 30 | | None -> () 31 | | Some timeout -> 32 | Fmt.pf ppf "?timeout:%a " Key.serialize_call (Key.v timeout) 33 | in 34 | Fmt.str {ocaml|%s.connect ~nameservers:%a %a%s|ocaml} modname 35 | pp_nameservers nameservers pp_timeout timeout stackv4v6 36 | | _ -> assert false 37 | in 38 | impl ~keys ~packages ~connect "Dns_client_mirage.Make" 39 | (random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> dns_client) 40 | -------------------------------------------------------------------------------- /lib/mirage/target/unix.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Key = Mirage_key 3 | 4 | type t = [ `Unix | `MacOSX ] 5 | 6 | let cast = function #t as t -> t | _ -> invalid_arg "not a unix target." 7 | let packages _ = [ Functoria.package ~min:"5.0.0" ~max:"6.0.0" "mirage-unix" ] 8 | 9 | (*Mirage unix is built on the host build context.*) 10 | let build_context ?build_dir:_ _ = [] 11 | let context_name _ = "default" 12 | let configure _ = Action.ok () 13 | let main i = Fpath.(base (rem_ext (Info.main i))) 14 | let public_name i = match Info.output i with None -> Info.name i | Some o -> o 15 | 16 | let dune i = 17 | let libraries = Info.libraries i in 18 | let flags = Mirage_dune.flags i in 19 | let public_name = public_name i in 20 | let main = Fpath.to_string (main i) in 21 | let pp_list f = Dune.compact_list f in 22 | let dune = 23 | Dune.stanzaf 24 | {| 25 | (rule 26 | (target %s) 27 | (enabled_if (= %%{context_name} "default")) 28 | (action 29 | (copy %s.exe %%{target}))) 30 | 31 | (executable 32 | (name %s) 33 | (libraries %a) 34 | (link_flags (-thread)) 35 | (modules (:standard \ %a)) 36 | (flags %a) 37 | (enabled_if (= %%{context_name} "default")) 38 | ) 39 | |} 40 | public_name main main (pp_list "libraries") libraries Fpath.pp 41 | (Fpath.rem_ext (Fpath.base (Info.config_file i))) 42 | (pp_list "flags") flags 43 | in 44 | [ dune ] 45 | 46 | let install i = 47 | let public_name = public_name i in 48 | Install.v ~bin:[ Fpath.(v public_name, v public_name) ] () 49 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_reporter.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Key = Mirage_key 3 | open Mirage_impl_pclock 4 | open Mirage_impl_misc 5 | 6 | type reporter = job 7 | 8 | let reporter = job 9 | 10 | let pp_level ppf = function 11 | | Some Logs.Error -> Fmt.string ppf "(Some Logs.Error)" 12 | | Some Logs.Warning -> Fmt.string ppf "(Some Logs.Warning)" 13 | | Some Logs.Info -> Fmt.string ppf "(Some Logs.Info)" 14 | | Some Logs.Debug -> Fmt.string ppf "(Some Logs.Debug)" 15 | | Some Logs.App -> Fmt.string ppf "(Some Logs.App)" 16 | | None -> Fmt.string ppf "None" 17 | 18 | let mirage_log ?ring_size ~default () = 19 | let logs = Key.logs in 20 | let packages = [ package ~min:"1.2.0" ~max:"2.0.0" "mirage-logs" ] in 21 | let keys = [ Key.v logs ] in 22 | let connect _ modname = function 23 | | [ _pclock ] -> 24 | Fmt.str 25 | "@[let ring_size = %a in@ let reporter = %s.create ?ring_size \ 26 | () in@ Mirage_runtime.set_level ~default:%a %a;@ %s.set_reporter \ 27 | reporter;@ Lwt.return reporter" 28 | Fmt.(Dump.option int) 29 | ring_size modname pp_level default pp_key logs modname 30 | | _ -> failwith (connect_err "log" 1) 31 | in 32 | impl ~packages ~keys ~connect "Mirage_logs.Make" (pclock @-> reporter) 33 | 34 | let default_reporter ?(clock = default_posix_clock) ?ring_size 35 | ?(level = Some Logs.Info) () = 36 | mirage_log ?ring_size ~default:level () $ clock 37 | 38 | let no_reporter = 39 | let connect _ _ _ = "assert false" in 40 | impl ~connect "Mirage_runtime" reporter 41 | -------------------------------------------------------------------------------- /lib/functoria/job.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** The representation of main tasks. *) 20 | 21 | type t 22 | (** Type for job values. *) 23 | 24 | val t : t Type.t 25 | (** [job] is the signature for user's application main module. *) 26 | 27 | val noop : t Impl.t 28 | (** [noop] is an implementation of {!Functoria.job} that holds no state, does 29 | nothing and has no dependency. *) 30 | 31 | val keys : 32 | ?runtime_package:string -> 33 | ?runtime_modname:string -> 34 | Argv.t Impl.t -> 35 | t Impl.t 36 | (** [keys a] is an implementation of {!Functoria.job} that holds the parsed 37 | command-line arguments. *) 38 | -------------------------------------------------------------------------------- /functoria.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Gabriel Radanne " 3 | authors: [ "Thomas Gazagnaire" 4 | "Anil Madhavapeddy" 5 | "Dave Scott" 6 | "Thomas Leonard" 7 | "Gabriel Radanne" ] 8 | homepage: "https://github.com/mirage/mirage" 9 | bug-reports: "https://github.com/mirage/mirage/issues" 10 | dev-repo: "git+https://github.com/mirage/mirage.git" 11 | doc: "https://mirage.github.io/mirage/" 12 | license: "ISC" 13 | tags: ["org:mirage"] 14 | available: opam-version >= "2.1.0" 15 | 16 | build: [ 17 | ["dune" "subst"] {dev} 18 | ["dune" "build" "-p" name "-j" jobs] 19 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 20 | ["env" "INSIDE_FUNCTORIA_TESTS=1" "dune" "exec" "-p" name "-j" jobs "--" 21 | "test/functoria/e2e/test.exe"] {with-test} 22 | ] 23 | 24 | depends: [ 25 | "ocaml" {>= "4.08.0"} 26 | "dune" {>= "2.9.0"} 27 | "dune" {with-test & >= "3.0.0"} 28 | "base-unix" 29 | "cmdliner" {>= "1.1.1"} 30 | "rresult" {>= "0.7.0"} 31 | "result" {>= "1.5"} 32 | "astring" 33 | "fmt" {>= "0.8.7"} 34 | "logs" 35 | "bos" 36 | "fpath" 37 | "emile" {>= "1.1"} 38 | "uri" {>= "4.2.0"} 39 | "alcotest" {with-test} 40 | "functoria-runtime" {= version & with-test} 41 | ] 42 | synopsis: "A DSL to organize functor applications" 43 | description: """ 44 | Functoria is a DSL to describe a set of modules and functors, their types and 45 | how to apply them in order to produce a complete application. 46 | 47 | The main use case is mirage. See the [mirage](https://github.com/mirage/mirage) 48 | repository for details. 49 | """ 50 | -------------------------------------------------------------------------------- /lib/functoria/type.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type _ t = 20 | | Type : 'a -> 'a t (* module type *) 21 | | Function : 'a t * 'b t -> ('a -> 'b) t 22 | 23 | let v x = Type x 24 | let ( @-> ) f x = Function (f, x) 25 | 26 | let rec pp : type a. a t Fmt.t = 27 | fun ppf -> function 28 | | Type _ -> Fmt.string ppf "_" 29 | | Function (a, b) -> Fmt.pf ppf "(%a -> %a)" pp a pp b 30 | 31 | type job = JOB 32 | 33 | let job = Type JOB 34 | 35 | (* Default argv *) 36 | 37 | type argv = ARGV 38 | 39 | let argv = Type ARGV 40 | 41 | (* Keys *) 42 | 43 | type info = INFO 44 | 45 | let info = Type INFO 46 | 47 | let is_functor : type a. a t -> bool = function 48 | | Type _ -> false 49 | | Function _ -> true 50 | -------------------------------------------------------------------------------- /lib/functoria/dune.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Dune files. *) 20 | 21 | type stanza 22 | 23 | val stanza : string -> stanza 24 | val stanzaf : ('a, Format.formatter, unit, stanza) format4 -> 'a 25 | 26 | type t 27 | 28 | val v : stanza list -> t 29 | val pp : t Fmt.t 30 | val to_string : t -> string 31 | val compact_list : ?indent:int -> string -> string list Fmt.t 32 | 33 | val base : 34 | packages:Package.t list -> 35 | name:string -> 36 | version:string -> 37 | config_ml_file:Fpath.t -> 38 | t 39 | (** [base] is a minimal [dune] file able to build [config.ml] *) 40 | 41 | val base_project : stanza list 42 | (** the minimal [dune-project] to compile [config.ml]. *) 43 | 44 | val base_workspace : t 45 | (** the minimal [dune-workspace] to compile [config.ml]. *) 46 | -------------------------------------------------------------------------------- /test/opam-monorepo/lock.t: -------------------------------------------------------------------------------- 1 | $ opam-monorepo lock --require-cross-compile 2 | ==> Using 1 locally scanned package as the target. 3 | ==> Found 8 opam dependencies for the target package. 4 | ==> Querying opam database for their metadata and Dune compatibility. 5 | ==> Calculating exact pins for each of them. 6 | ==> Wrote lockfile with 4 entries to $TESTCASE_ROOT/unikernel.opam.locked. You can now run opam monorepo pull to fetch their sources. 7 | 8 | $ cat unikernel.opam.locked 9 | opam-version: "2.0" 10 | synopsis: "opam-monorepo generated lockfile" 11 | maintainer: "opam-monorepo" 12 | depends: [ 13 | "dune" {= "3.0.0"} 14 | "fmt" {= "0.9.0+dune" & ?vendor} 15 | "gmp" {= "6.2.9+dune" & ?vendor} 16 | "mirage-runtime" {= "4.0.0" & ?vendor} 17 | "ocaml-base-compiler" {= "4.13.1"} 18 | "ocaml-solo5" {= "0.8.0"} 19 | "solo5" {= "0.7.1"} 20 | "zarith" {= "1.12+dune+mirage" & ?vendor} 21 | ] 22 | pin-depends: [ 23 | ["fmt.0.9.0+dune" "https://fmt.src"] 24 | ["gmp.6.2.9+dune" "https://gmp.src"] 25 | ["mirage-runtime.4.0.0" "https://mirage.src"] 26 | ["zarith.1.12+dune+mirage" "https://github.com/ocaml/zarith.git"] 27 | ] 28 | x-opam-monorepo-cli-args: ["--require-cross-compile"] 29 | x-opam-monorepo-duniverse-dirs: [ 30 | ["https://fmt.src" "fmt"] 31 | ["https://github.com/ocaml/zarith.git" "zarith"] 32 | ["https://gmp.src" "gmp"] 33 | ["https://mirage.src" "mirage"] 34 | ] 35 | x-opam-monorepo-opam-provided: ["ocaml-solo5"] 36 | x-opam-monorepo-opam-repositories: [ 37 | "file://$OPAM_MONOREPO_CWD/mini-opam-overlays" 38 | "file://$OPAM_MONOREPO_CWD/mini-opam-repository" 39 | ] 40 | x-opam-monorepo-root-packages: ["unikernel"] 41 | x-opam-monorepo-version: "0.3" 42 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_network.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Key = Mirage_key 3 | 4 | type network = NETWORK 5 | 6 | let network = Type.v NETWORK 7 | let all_networks = ref [] 8 | 9 | let network_conf (intf : string Key.key) = 10 | let key = Key.v intf in 11 | let keys = [ key ] in 12 | let packages_v = 13 | Key.match_ Key.(value target) @@ function 14 | | `Unix -> [ package ~min:"3.0.0" ~max:"4.0.0" "mirage-net-unix" ] 15 | | `MacOSX -> [ package ~min:"1.8.0" ~max:"2.0.0" "mirage-net-macosx" ] 16 | | `Xen -> [ package ~min:"2.1.0" ~max:"3.0.0" "mirage-net-xen" ] 17 | | `Qubes -> 18 | [ 19 | package ~min:"2.1.0" ~max:"3.0.0" "mirage-net-xen"; 20 | Mirage_impl_qubesdb.pkg; 21 | ] 22 | | #Mirage_key.mode_solo5 -> 23 | [ package ~min:"0.8.0" ~max:"0.9.0" "mirage-net-solo5" ] 24 | in 25 | let connect _ modname _ = 26 | (* @samoht: why not just use the args paramater? *) 27 | Fmt.str "%s.connect %a" modname Key.serialize_call key 28 | in 29 | let configure i = 30 | all_networks := Key.get (Info.context i) intf :: !all_networks; 31 | Action.ok () 32 | in 33 | impl ~keys ~packages_v ~connect ~configure "Netif" network 34 | 35 | let netif ?group dev = network_conf @@ Key.interface ?group dev 36 | 37 | let default_network = 38 | match_impl 39 | Key.(value target) 40 | [ 41 | (`Unix, netif "tap0"); 42 | (`MacOSX, netif "tap0"); 43 | (* On Solo5 targets, a single default network is customarily 44 | * named just 'service' *) 45 | (`Hvt, netif "service"); 46 | (`Spt, netif "service"); 47 | (`Virtio, netif "service"); 48 | (`Muen, netif "service"); 49 | (`Genode, netif "service"); 50 | ] 51 | ~default:(netif "0") 52 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_resolver.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Key = Mirage_key 3 | open Mirage_impl_misc 4 | open Mirage_impl_mclock 5 | open Mirage_impl_pclock 6 | open Mirage_impl_stack 7 | open Mirage_impl_random 8 | open Mirage_impl_time 9 | 10 | type resolver = Resolver 11 | 12 | let resolver = Type.v Resolver 13 | 14 | let resolver_unix_system = 15 | let packages_v = 16 | Key.(if_ is_unix) 17 | [ 18 | Mirage_impl_conduit.pkg; 19 | package ~min:"4.0.0" ~max:"7.0.0" "conduit-lwt-unix"; 20 | ] 21 | [] 22 | in 23 | let configure i = 24 | match get_target i with 25 | | `Unix | `MacOSX -> Action.ok () 26 | | _ -> Action.error "Unix resolver not supported on non-UNIX targets." 27 | in 28 | let connect _ _modname _ = "Lwt.return Resolver_lwt_unix.system" in 29 | impl ~packages_v ~configure ~connect "Resolver_lwt" resolver 30 | 31 | let resolver_dns_conf ~ns = 32 | let packages = [ Mirage_impl_conduit.pkg ] in 33 | let keys = Key.[ v ns ] in 34 | let connect _ modname = function 35 | | [ _r; _t; _m; _p; stack ] -> 36 | Fmt.str 37 | "let nameservers = %a in@;\ 38 | %s.v ?nameservers %s >|= function@;\ 39 | | Ok r -> r@;\ 40 | | Error (`Msg e) -> invalid_arg e@;" 41 | pp_key ns modname stack 42 | | _ -> failwith (connect_err "resolver" 3) 43 | in 44 | impl ~packages ~keys ~connect "Resolver_mirage.Make" 45 | (random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> resolver) 46 | 47 | let resolver_dns ?ns ?(time = default_time) ?(mclock = default_monotonic_clock) 48 | ?(pclock = default_posix_clock) ?(random = default_random) stack = 49 | let ns = Key.resolver ?default:ns () in 50 | resolver_dns_conf ~ns $ random $ time $ mclock $ pclock $ stack 51 | -------------------------------------------------------------------------------- /mirage.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: ["anil@recoil.org" "thomas@gazagnaire.org"] 3 | authors: ["Thomas Gazagnaire" "Anil Madhavapeddy" "Gabriel Radanne" 4 | "Mindy Preston" "Thomas Leonard" "Nicolas Ojeda Bar" 5 | "Dave Scott" "David Kaloper" "Hannes Mehnert" "Richard Mortier"] 6 | homepage: "https://github.com/mirage/mirage" 7 | bug-reports: "https://github.com/mirage/mirage/issues/" 8 | dev-repo: "git+https://github.com/mirage/mirage.git" 9 | license: "ISC" 10 | tags: ["org:mirage" "org:xapi-project"] 11 | doc: "https://mirage.github.io/mirage/" 12 | available: opam-version >= "2.1.0" 13 | 14 | build: [ 15 | ["dune" "subst"] {dev} 16 | ["dune" "build" "-p" name "-j" jobs] 17 | ["dune" "runtest" "-p" name "-j" jobs] {with-test & os != "macos"} 18 | ] 19 | 20 | depends: [ 21 | "ocaml" {>= "4.08.0"} 22 | "dune" {>= "2.9.0"} 23 | "dune" {with-test & >= "3.0.0"} 24 | "ipaddr" {>= "5.0.0"} 25 | "functoria" {= version} 26 | "bos" 27 | "astring" 28 | "logs" 29 | "mirage-runtime" {= version} 30 | "opam-monorepo" {>= "0.3.2"} 31 | "alcotest" {with-test} 32 | "fmt" {>= "0.8.7" & with-test} 33 | ] 34 | synopsis: "The MirageOS library operating system" 35 | description: """ 36 | MirageOS is a library operating system that constructs unikernels for 37 | secure, high-performance network applications across a variety of 38 | cloud computing and mobile platforms. Code can be developed on a 39 | normal OS such as Linux or MacOS X, and then compiled into a 40 | fully-standalone, specialised unikernel that runs under the Xen 41 | hypervisor. 42 | 43 | Since Xen powers most public cloud computing infrastructure such as 44 | Amazon EC2 or Rackspace, this lets your servers run more cheaply, 45 | securely and with finer control than with a full software stack. 46 | """ 47 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_happy_eyeballs.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_time 3 | open Mirage_impl_mclock 4 | open Mirage_impl_stack 5 | open Mirage_impl_dns 6 | 7 | type happy_eyeballs = Happy_eyeballs 8 | 9 | let happy_eyeballs = Type.v Happy_eyeballs 10 | 11 | let generic_happy_eyeballs aaaa_timeout v6_connect_timeout connect_timeout 12 | resolve_timeout resolve_retries timer_interval = 13 | let packages = 14 | [ package "happy-eyeballs-mirage" ~min:"0.3.0" ~max:"1.0.0" ] 15 | in 16 | let keys = 17 | let cons_if_some v l = match v with Some x -> x :: l | None -> l in 18 | cons_if_some aaaa_timeout [] 19 | |> cons_if_some v6_connect_timeout 20 | |> cons_if_some resolve_timeout 21 | |> cons_if_some resolve_retries 22 | |> cons_if_some timer_interval 23 | |> List.map Key.v 24 | in 25 | let connect _info modname = function 26 | | [ _time; _mclock; stack; dns ] -> 27 | let pp_optional_argument ~name ppf = function 28 | | None -> () 29 | | Some key -> Fmt.pf ppf "?%s:%a " name Key.serialize_call (Key.v key) 30 | in 31 | Fmt.str {ocaml|%s.connect_device %a%a%a%a%a%a %s %s|ocaml} modname 32 | (pp_optional_argument ~name:"aaaa_timeout") 33 | aaaa_timeout 34 | (pp_optional_argument ~name:"v6_connect_timeout") 35 | v6_connect_timeout 36 | (pp_optional_argument ~name:"connect_timeout") 37 | connect_timeout 38 | (pp_optional_argument ~name:"resolve_timeout") 39 | resolve_timeout 40 | (pp_optional_argument ~name:"resolve_retries") 41 | resolve_retries 42 | (pp_optional_argument ~name:"timer_interval") 43 | timer_interval dns stack 44 | | _ -> assert false 45 | in 46 | impl ~keys ~packages ~connect "Happy_eyeballs_mirage.Make" 47 | (time @-> mclock @-> stackv4v6 @-> dns_client @-> happy_eyeballs) 48 | -------------------------------------------------------------------------------- /lib/functoria/typeid.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Typed identifiers and equality witnesses *) 20 | 21 | type 'a t 22 | (** A typed unique identifiers *) 23 | 24 | val gen : unit -> 'a t 25 | (** [gen ()] creates a new unique identifier. *) 26 | 27 | val equal : 'r t -> 's t -> bool 28 | (** [equal tid1 tid2] tests if [tid1] and [tid2] are equal. *) 29 | 30 | val id : 'a t -> int 31 | (** [id tid] returns a integer that uniquely identify [tid]. *) 32 | 33 | val pp : Format.formatter -> 'a t -> unit 34 | (** [pp ppf tid] prints [id tif]. *) 35 | 36 | (** A annotated boolean that also witness the equality between two types. *) 37 | type (_, _) witness = Eq : ('a, 'a) witness | NotEq : ('a, 'b) witness 38 | 39 | val witness : 'r t -> 's t -> ('r, 's) witness 40 | (** [witness tid1 tid2] is equivalent to [equal tid1 tid2], but exposes the 41 | equality between their types. *) 42 | 43 | val to_bool : ('a, 'b) witness -> bool 44 | (** [to_bool w] converts the witness into a boolean. *) 45 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_udp.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_ip 3 | open Mirage_impl_misc 4 | open Mirage_impl_random 5 | module Key = Mirage_key 6 | 7 | type 'a udp = UDP 8 | type udpv4v6 = v4v6 udp 9 | 10 | let udp = Type.Type UDP 11 | let udpv4v6 : udpv4v6 typ = udp 12 | 13 | (* Value restriction ... *) 14 | let udp_direct_func () = 15 | let packages_v = right_tcpip_library ~sublibs:[ "udp" ] "tcpip" in 16 | let connect _ modname = function 17 | | [ ip; _random ] -> Fmt.str "%s.connect %s" modname ip 18 | | _ -> failwith (connect_err "udp" 2) 19 | in 20 | impl ~packages_v ~connect "Udp.Make" (ip @-> random @-> udp) 21 | 22 | let direct_udp ?(random = default_random) ip = udp_direct_func () $ ip $ random 23 | 24 | let udpv4v6_socket_conf ~ipv4_only ~ipv6_only ipv4_key ipv6_key = 25 | let keys = 26 | [ Key.v ipv4_only; Key.v ipv6_only; Key.v ipv4_key; Key.v ipv6_key ] 27 | in 28 | let packages_v = right_tcpip_library ~sublibs:[ "udpv4v6-socket" ] "tcpip" in 29 | let configure i = 30 | match get_target i with 31 | | `Unix | `MacOSX -> Action.ok () 32 | | _ -> Action.error "UDPv4v6 socket not supported on non-UNIX targets." 33 | in 34 | let connect _ modname _ = 35 | Fmt.str "%s.connect ~ipv4_only:%a ~ipv6_only:%a %a %a" modname pp_key 36 | ipv4_only pp_key ipv6_only pp_key ipv4_key pp_key ipv6_key 37 | in 38 | impl ~keys ~packages_v ~configure ~connect "Udpv4v6_socket" udpv4v6 39 | 40 | let socket_udpv4v6 ?group ipv4 ipv6 = 41 | let ipv4 = 42 | match ipv4 with 43 | | None -> Ipaddr.V4.Prefix.global 44 | | Some ip -> Ipaddr.V4.Prefix.make 32 ip 45 | and ipv6 = 46 | match ipv6 with 47 | | None -> None 48 | | Some ip -> Some (Ipaddr.V6.Prefix.make 128 ip) 49 | and ipv4_only = Key.ipv4_only ?group () 50 | and ipv6_only = Key.ipv6_only ?group () in 51 | udpv4v6_socket_conf ~ipv4_only ~ipv6_only 52 | (Key.V4.network ?group ipv4) 53 | (Key.V6.network ?group ipv6) 54 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_tracing.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_misc 3 | module Key = Mirage_key 4 | 5 | type tracing = job 6 | 7 | let tracing = job 8 | 9 | let mprof_trace ~size () = 10 | let unix_trace_file = "trace.ctf" in 11 | let key = Key.tracing_size size in 12 | let keys = [ Key.v key ] in 13 | let packages_v = 14 | Key.match_ Key.(value target) @@ function 15 | | #Mirage_key.mode_xen -> 16 | [ 17 | package ~max:"1.0.0" "mirage-profile"; 18 | package ~max:"1.0.0" ~min:"0.9.0" "mirage-profile-xen"; 19 | ] 20 | | #Mirage_key.mode_solo5 -> [] 21 | | #Mirage_key.mode_unix -> 22 | [ 23 | package ~max:"1.0.0" "mirage-profile"; 24 | package ~max:"1.0.0" "mirage-profile-unix"; 25 | ] 26 | in 27 | let connect i _ _ = 28 | match get_target i with 29 | | #Mirage_key.mode_solo5 -> 30 | failwith "tracing is not currently implemented for solo5 targets" 31 | | #Mirage_key.mode_unix -> 32 | Fmt.str 33 | "Lwt.return ())@.let () = (@ @[ let buffer = \ 34 | MProf_unix.mmap_buffer ~size:%a %S in@ let trace_config = \ 35 | MProf.Trace.Control.make buffer MProf_unix.timestamper in@ \ 36 | MProf.Trace.Control.start trace_config@]" 37 | Key.serialize_call (Key.v key) unix_trace_file 38 | | #Mirage_key.mode_xen -> 39 | Fmt.str 40 | "Lwt.return ())@.let () = (@ @[ let trace_pages = \ 41 | MProf_xen.make_shared_buffer ~size:%a in@ let buffer = trace_pages \ 42 | |> Io_page.to_cstruct |> Cstruct.to_bigarray in@ let trace_config = \ 43 | MProf.Trace.Control.make buffer MProf_xen.timestamper in@ \ 44 | MProf.Trace.Control.start trace_config;@ MProf_xen.share_with \ 45 | ~domid:0 trace_pages@ |> Xen_os.Main.run@]" 46 | Key.serialize_call (Key.v key) 47 | in 48 | impl ~keys ~packages_v ~connect "MProf" job 49 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_ip.mli: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_arpv4 3 | open Mirage_impl_ethernet 4 | open Mirage_impl_mclock 5 | open Mirage_impl_network 6 | open Mirage_impl_qubesdb 7 | open Mirage_impl_random 8 | 9 | type v4 10 | type v6 11 | type v4v6 12 | type 'a ip 13 | type ipv4 = v4 ip 14 | type ipv6 = v6 ip 15 | type ipv4v6 = v4v6 ip 16 | 17 | val ip : 'a ip Functoria.typ 18 | val ipv4 : ipv4 Functoria.typ 19 | val ipv6 : ipv6 Functoria.typ 20 | val ipv4v6 : ipv4v6 Functoria.typ 21 | 22 | type ipv4_config = { 23 | network : Ipaddr.V4.Prefix.t; 24 | gateway : Ipaddr.V4.t option; 25 | } 26 | 27 | type ipv6_config = { 28 | network : Ipaddr.V6.Prefix.t; 29 | gateway : Ipaddr.V6.t option; 30 | } 31 | 32 | val create_ipv4 : 33 | ?group:string -> 34 | ?config:ipv4_config -> 35 | ?no_init:bool Mirage_key.key -> 36 | ?random:random impl -> 37 | ?clock:mclock impl -> 38 | ethernet impl -> 39 | arpv4 impl -> 40 | ipv4 impl 41 | 42 | val create_ipv6 : 43 | ?random:random impl -> 44 | ?time:Mirage_impl_time.time impl -> 45 | ?clock:mclock impl -> 46 | ?group:string -> 47 | ?config:ipv6_config -> 48 | ?no_init:bool Mirage_key.key -> 49 | network impl -> 50 | ethernet impl -> 51 | ipv6 impl 52 | 53 | val ipv4_of_dhcp : 54 | ?random:random impl -> 55 | ?clock:mclock impl -> 56 | ?time:Mirage_impl_time.time impl -> 57 | network impl -> 58 | ethernet impl -> 59 | arpv4 impl -> 60 | ipv4 impl 61 | 62 | val ipv4_qubes : 63 | ?random:random impl -> 64 | ?clock:mclock impl -> 65 | qubesdb impl -> 66 | ethernet impl -> 67 | arpv4 impl -> 68 | ipv4 impl 69 | 70 | val create_ipv4v6 : ?group:string -> ipv4 impl -> ipv6 impl -> ipv4v6 impl 71 | 72 | val keyed_ipv4v6 : 73 | ipv4_only:bool Mirage_key.key -> 74 | ipv6_only:bool Mirage_key.key -> 75 | ipv4 impl -> 76 | ipv6 impl -> 77 | ipv4v6 impl 78 | 79 | val right_tcpip_library : 80 | ?libs:string list -> sublibs:string list -> string -> package list value 81 | -------------------------------------------------------------------------------- /lib/functoria/context.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Universal map of keys *) 20 | 21 | type 'a key 22 | (** The type for keys. *) 23 | 24 | val new_key : string -> 'a key 25 | (** [new_key n] is a new key with name [k]. *) 26 | 27 | type t 28 | (** The type for context maps. *) 29 | 30 | val empty : t 31 | (** [empty] is the empty context. *) 32 | 33 | val add : 'a key -> 'a -> t -> t 34 | (** [add k v t] is [t] augmented with the binding [(k, v)]. Any previous binding 35 | of [k] is removed. *) 36 | 37 | val mem : 'a key -> t -> bool 38 | (** [mem k t] is true iff [k] has been added to [t]. *) 39 | 40 | val find : 'a key -> t -> 'a option 41 | (** [find k t] is [v] is the binding [(k, v)] has been added to [t], otherwise 42 | it is [None]. *) 43 | 44 | val merge : default:t -> t -> t 45 | (** [merge ~default t] merges [t] on top of [default]. If a key appears in both 46 | [default] and [t], the value present in [t] is kept. *) 47 | 48 | val dump : t Fmt.t 49 | (** [dump] dumps the state of [t]. *) 50 | -------------------------------------------------------------------------------- /lib/functoria/context.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type 'a key = { name : string; put : 'a -> exn; get : exn -> 'a } 20 | 21 | let new_key (type a) name = 22 | let module M = struct 23 | exception E of a 24 | end in 25 | let put a = M.E a in 26 | let get = function 27 | | M.E a -> a 28 | | _ -> raise @@ Invalid_argument ("duplicate key: " ^ name) 29 | in 30 | { name; put; get } 31 | 32 | module Map = Map.Make (String) 33 | 34 | type t = exn Map.t 35 | 36 | let empty = Map.empty 37 | let add k v (t : t) : t = Map.add k.name (k.put v) t 38 | let mem k (t : t) = Map.mem k.name t 39 | 40 | let find k (t : t) = 41 | if Map.mem k.name t then Some (k.get @@ Map.find k.name t) else None 42 | 43 | let dump : t Fmt.t = 44 | let pp_elt ppf (k, v) = Fmt.pf ppf "[%s: %a]" k Fmt.exn v in 45 | let map_iter f = Map.iter (fun k v -> f (k, v)) in 46 | Fmt.box ~indent:2 @@ Fmt.(iter ~sep:(any "@ ")) map_iter pp_elt 47 | 48 | let merge ~default m = 49 | let aux _ _ v = Some v in 50 | Map.union aux default m 51 | -------------------------------------------------------------------------------- /test/functoria/context/run.t: -------------------------------------------------------------------------------- 1 | Query package - no target - x.context 2 | $ ./config.exe query package --context-file=x.context 3 | "fmt" { ?monorepo } 4 | "functoria-runtime" { ?monorepo } 5 | "x" { ?monorepo } 6 | 7 | Query package - no target - y.context 8 | $ ./config.exe query package --context-file=y.context 9 | "fmt" { ?monorepo } 10 | "functoria-runtime" { ?monorepo } 11 | "y" { ?monorepo } 12 | 13 | Query package - x target - y.context 14 | $ ./config.exe query package -t x --context-file=y.context 15 | "fmt" { ?monorepo } 16 | "functoria-runtime" { ?monorepo } 17 | "x" { ?monorepo } 18 | 19 | Query package - y target - x.context 20 | $ ./config.exe query package -t y --context-file=x.context 21 | "fmt" { ?monorepo } 22 | "functoria-runtime" { ?monorepo } 23 | "y" { ?monorepo } 24 | 25 | Describe - no target - x.context 26 | $ ./config.exe describe --context-file=x.context 27 | Name noop 28 | Keys target=x, 29 | vote=cat (default), 30 | warn_error=false (default) 31 | 32 | Describe - no target - y.context 33 | $ ./config.exe describe --context-file=y.context 34 | Name noop 35 | Keys target=y, 36 | vote=cat (default), 37 | warn_error=false (default) 38 | 39 | Describe - x target - y.context 40 | $ ./config.exe describe -t x --context-file=y.context 41 | Name noop 42 | Keys target=x, 43 | vote=cat (default), 44 | warn_error=false (default) 45 | 46 | Describe - y target - x.context 47 | $ ./config.exe describe -t y --context-file=x.context 48 | Name noop 49 | Keys target=y, 50 | vote=cat (default), 51 | warn_error=false (default) 52 | 53 | Bad context cache 54 | $ ./config.exe configure -t nonexistent --context-file=z.context 55 | test: option '-t': invalid value 'nonexistent', expected either 'y' or 'x' 56 | Usage: test configure [OPTION]… 57 | Try 'test configure --help' or 'test --help' for more information. 58 | [1] 59 | -------------------------------------------------------------------------------- /lib/functoria/tool.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Creation of CLI tools to assemble functors. *) 20 | 21 | open DSL 22 | 23 | module type S = sig 24 | val name : string 25 | (** Name of the tool. *) 26 | 27 | val version : string 28 | (** Version of the tool. *) 29 | 30 | val packages : package list 31 | (** The packages to load when compiling the configuration file. *) 32 | 33 | val create : job impl list -> job impl 34 | end 35 | 36 | module Make (P : S) : sig 37 | val run : unit -> unit 38 | (** Run the configuration builder. This should be called exactly once to run 39 | the configuration builder: command-line arguments will be parsed, and some 40 | code will be generated and compiled. *) 41 | 42 | val run_with_argv : 43 | ?help_ppf:Format.formatter -> 44 | ?err_ppf:Format.formatter -> 45 | string array -> 46 | unit 47 | (** [run_with_argv a] is the same as {!run} but parses [a] instead of the 48 | process command line arguments. It also allows to set the error and help 49 | channels using [help_ppf] and [err_ppf]. *) 50 | end 51 | -------------------------------------------------------------------------------- /test/f0/f0.ml: -------------------------------------------------------------------------------- 1 | (* A very simple engine *) 2 | 3 | open Functoria 4 | module Key = Key 5 | 6 | let warn_error = 7 | let doc = "Enable -warn-error when compiling OCaml sources." in 8 | let doc = Key.Arg.info ~docv:"BOOL" ~doc [ "warn-error" ] in 9 | let key = Key.Arg.(opt ~stage:`Configure bool false doc) in 10 | Key.create "warn_error" key 11 | 12 | let vote = 13 | let doc = "Vote." in 14 | let doc = Key.Arg.info ~docv:"VOTE" ~doc [ "vote" ] in 15 | let key = Key.Arg.(opt ~stage:`Configure string "cat" doc) in 16 | Key.create "vote" key 17 | 18 | let file_of_key k = Fpath.v Key.(name @@ v k) 19 | 20 | let write_key i k f = 21 | let context = Info.context i in 22 | let file = file_of_key k in 23 | let contents = f (Key.get context k) in 24 | Action.write_file file contents 25 | 26 | module C = struct 27 | open Action.Syntax 28 | 29 | let prelude _ = "" 30 | let name = "test" 31 | let version = "1.0~test" 32 | let packages = [ package "functoria"; package "f0" ] 33 | let keys = Key.[ v vote; v warn_error ] 34 | let connect _ _ _ = "()" 35 | 36 | let dune i = 37 | let dune = 38 | Dune.stanzaf 39 | {| 40 | (executable 41 | (public_name f0) 42 | (package functoria) 43 | (name %s) 44 | (modules (:standard \ config)) 45 | (promote (until-clean)) 46 | (libraries cmdliner fmt functoria-runtime)) 47 | |} 48 | Fpath.(basename @@ rem_ext @@ Info.main i) 49 | in 50 | [ dune ] 51 | 52 | let configure i = 53 | let* () = write_key i vote (fun x -> x) in 54 | write_key i warn_error string_of_bool 55 | 56 | let create jobs = 57 | let packages = [ package "fmt" ] in 58 | let extra_deps = List.map dep jobs in 59 | impl ~keys ~packages ~connect ~dune ~configure ~extra_deps 60 | ~install:(fun _ -> Install.v ~bin:[ Fpath.(v "f0.exe", v "f0") ] ()) 61 | "F0" job 62 | 63 | let name_of_target i = Info.name i 64 | let dune_project = [] 65 | let dune_workspace = None 66 | let context_name _ = "default" 67 | end 68 | 69 | include Lib.Make (C) 70 | module Tool = Tool.Make (C) 71 | -------------------------------------------------------------------------------- /test/functoria/test_package.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | 3 | let w = Package.v ~min:"1.0" ~max:"2.0" "foo" ~scope:`Switch 4 | let x = Package.v ~min:"1.0" ~max:"2.0" "foo" 5 | let y = Package.v ~min:"0.9" ~max:"1.9" ~sublibs:[ "bar" ] "foo" 6 | let z = Package.v "bar" ~sublibs:[ "foo" ] ~min:"42" 7 | 8 | let xy = 9 | match Package.merge x y with 10 | | Some x -> x 11 | | None -> Alcotest.fail "xy should not be None" 12 | 13 | let test_package_merge () = 14 | let () = 15 | match Package.merge x z with 16 | | Some _ -> Alcotest.fail "xz should be None" 17 | | None -> () 18 | in 19 | Alcotest.(check (list string)) 20 | "min" (Package.min_versions xy) [ "0.9"; "1.0" ]; 21 | Alcotest.(check (list string)) 22 | "max" (Package.max_versions xy) [ "1.9"; "2.0" ] 23 | 24 | let test_package_pp () = 25 | let str = Fmt.to_to_string Package.pp in 26 | let str' = Fmt.to_to_string (Package.pp ~surround:"x") in 27 | Alcotest.(check string) 28 | "pp(x)" (str x) {|foo { ?monorepo & >= "1.0" & < "2.0" }|}; 29 | Alcotest.(check string) 30 | "pp(xy)" (str xy) 31 | {|foo { ?monorepo & >= "0.9" & >= "1.0" & < "1.9" & < "2.0" }|}; 32 | Alcotest.(check string) "pp(z)" (str z) {|bar { ?monorepo & >= "42" }|}; 33 | Alcotest.(check string) 34 | "pp'(x)" (str' x) {|xfoox { ?monorepo & >= "1.0" & < "2.0" }|}; 35 | Alcotest.(check string) "pp(w)" (str w) {|foo { >= "1.0" & < "2.0" }|}; 36 | Alcotest.(check string) "key(x)" (Package.key x) "monorepo-foo"; 37 | Alcotest.(check string) "key(w)" (Package.key w) "switch-foo" 38 | 39 | let test_invalid_package_names () = 40 | let check_name_is_invalid name = 41 | Alcotest.check_raises name 42 | (Invalid_argument (Fmt.str "package name %S is invalid" name)) 43 | (fun () -> Package.v name |> ignore) 44 | in 45 | check_name_is_invalid "bar.subfoo"; 46 | check_name_is_invalid "000"; 47 | check_name_is_invalid "é" 48 | 49 | let suite = 50 | [ 51 | ("merge", `Quick, test_package_merge); 52 | ("pp", `Quick, test_package_pp); 53 | ("invalid names", `Quick, test_invalid_package_names); 54 | ] 55 | -------------------------------------------------------------------------------- /lib/functoria/typeid.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type (_, _) witness = Eq : ('a, 'a) witness | NotEq : ('a, 'b) witness 20 | 21 | let to_bool : type a b. (a, b) witness -> bool = function 22 | | Eq -> true 23 | | NotEq -> false 24 | 25 | module Id = struct 26 | type _ t = .. 27 | end 28 | 29 | module type ID = sig 30 | type t 31 | type _ Id.t += Tid : t Id.t 32 | 33 | val id : int 34 | end 35 | 36 | type 'a t = (module ID with type t = 'a) 37 | 38 | let gen_id = 39 | let r = ref 0 in 40 | fun () -> 41 | incr r; 42 | !r 43 | 44 | let gen () (type s) = 45 | let module M = struct 46 | type t = s 47 | type _ Id.t += Tid : t Id.t 48 | 49 | let id = gen_id () 50 | end in 51 | (module M : ID with type t = s) 52 | 53 | let witness : type r s. r t -> s t -> (r, s) witness = 54 | fun r s -> 55 | let module R = (val r : ID with type t = r) in 56 | let module S = (val s : ID with type t = s) in 57 | match R.Tid with S.Tid -> Eq | _ -> NotEq 58 | 59 | let equal a b = to_bool @@ witness a b 60 | let pp (type a) ppf ((module M) : a t) = Fmt.int ppf M.id 61 | let id (type a) ((module M) : a t) = M.id 62 | -------------------------------------------------------------------------------- /test/functoria/e2e/lib/e2e.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | module Key = Key 3 | 4 | let warn_error = 5 | let doc = "Enable -warn-error when compiling OCaml sources." in 6 | let doc = Key.Arg.info ~docv:"BOOL" ~doc [ "warn-error" ] in 7 | let key = Key.Arg.(opt ~stage:`Configure bool false doc) in 8 | Key.create "warn_error" key 9 | 10 | let vote = 11 | let doc = "Vote." in 12 | let doc = Key.Arg.info ~docv:"VOTE" ~doc [ "vote" ] in 13 | let key = Key.Arg.(opt ~stage:`Configure string "cat" doc) in 14 | Key.create "vote" key 15 | 16 | let file_of_key k = Fpath.v Key.(name @@ v k) 17 | 18 | let write_key i k f = 19 | let context = Info.context i in 20 | let file = file_of_key k in 21 | let contents = f (Key.get context k) in 22 | Action.write_file file contents 23 | 24 | module C = struct 25 | open Action.Syntax 26 | 27 | let prelude _ = "let (>>=) x f = f x\nlet return x = x\nlet run x = x" 28 | let name = "test" 29 | let version = "1.0~test" 30 | let packages = [ package "functoria"; package "e2e" ] 31 | let keys = Key.[ v vote; v warn_error ] 32 | let connect _ _ _ = "()" 33 | let main i = Fpath.(basename @@ rem_ext @@ Info.main i) 34 | 35 | let dune i = 36 | let dune = 37 | Dune.stanzaf 38 | {| 39 | (executable 40 | (name %s) 41 | (modules (:standard \ config)) 42 | (promote (until-clean)) 43 | (libraries cmdliner fmt functoria-runtime)) 44 | |} 45 | (main i) 46 | in 47 | [ dune ] 48 | 49 | let configure i = 50 | let* () = write_key i vote (fun x -> x) in 51 | write_key i warn_error string_of_bool 52 | 53 | let create jobs = 54 | let packages = [ package "fmt" ] in 55 | let extra_deps = List.map dep jobs in 56 | let install i = Install.v ~bin:[ Fpath.(v (main i) + "exe", v "e2e") ] () in 57 | impl ~keys ~packages ~connect ~dune ~configure ~extra_deps ~install "E2e" 58 | job 59 | 60 | let name_of_target i = Info.name i 61 | let dune_project = [] 62 | let dune_workspace = None 63 | let context_name _ = "default" 64 | end 65 | 66 | include Lib.Make (C) 67 | include Tool.Make (C) 68 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_tcp.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_ip 3 | open Mirage_impl_mclock 4 | open Mirage_impl_misc 5 | open Mirage_impl_random 6 | open Mirage_impl_time 7 | module Key = Mirage_key 8 | 9 | type 'a tcp = TCP 10 | type tcpv4v6 = v4v6 tcp 11 | 12 | let tcp = Type.Type TCP 13 | let tcpv4v6 : tcpv4v6 typ = tcp 14 | 15 | (* this needs to be a function due to the value restriction. *) 16 | let tcp_direct_func () = 17 | let packages_v = right_tcpip_library ~sublibs:[ "tcp" ] "tcpip" in 18 | let connect _ modname = function 19 | | [ ip; _time; _clock; _random ] -> Fmt.str "%s.connect %s" modname ip 20 | | _ -> failwith (connect_err "direct tcp" 4) 21 | in 22 | impl ~packages_v ~connect "Tcp.Flow.Make" 23 | (ip @-> time @-> mclock @-> random @-> tcp) 24 | 25 | let direct_tcp ?(mclock = default_monotonic_clock) ?(time = default_time) 26 | ?(random = default_random) ip = 27 | tcp_direct_func () $ ip $ time $ mclock $ random 28 | 29 | let tcpv4v6_socket_conf ~ipv4_only ~ipv6_only ipv4_key ipv6_key = 30 | let keys = 31 | [ Key.v ipv4_only; Key.v ipv6_only; Key.v ipv4_key; Key.v ipv6_key ] 32 | in 33 | let packages_v = right_tcpip_library ~sublibs:[ "tcpv4v6-socket" ] "tcpip" in 34 | let configure i = 35 | match get_target i with 36 | | `Unix | `MacOSX -> Action.ok () 37 | | _ -> Action.error "TCPv4v6 socket not supported on non-UNIX targets." 38 | in 39 | let connect _ modname _ = 40 | Fmt.str "%s.connect ~ipv4_only:%a ~ipv6_only:%a %a %a" modname pp_key 41 | ipv4_only pp_key ipv6_only pp_key ipv4_key pp_key ipv6_key 42 | in 43 | impl ~packages_v ~configure ~keys ~connect "Tcpv4v6_socket" tcpv4v6 44 | 45 | let socket_tcpv4v6 ?group ipv4 ipv6 = 46 | let ipv4 = 47 | match ipv4 with 48 | | None -> Ipaddr.V4.Prefix.global 49 | | Some ip -> Ipaddr.V4.Prefix.make 32 ip 50 | and ipv6 = 51 | match ipv6 with 52 | | None -> None 53 | | Some ip -> Some (Ipaddr.V6.Prefix.make 128 ip) 54 | and ipv4_only = Key.ipv4_only ?group () 55 | and ipv6_only = Key.ipv6_only ?group () in 56 | tcpv4v6_socket_conf ~ipv4_only ~ipv6_only 57 | (Key.V4.network ?group ipv4) 58 | (Key.V6.network ?group ipv6) 59 | -------------------------------------------------------------------------------- /test/mirage/query/gen.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | cmd : string; 3 | file : string; 4 | args : string option; 5 | target : [ `Unix | `Hvt ]; 6 | } 7 | 8 | let target_str = function `Unix -> "unix" | `Hvt -> "hvt" 9 | let v ?args x target = { cmd = "query " ^ x; file = x; target; args } 10 | 11 | let gen t = 12 | let file = 13 | match t.target with 14 | | `Unix -> t.file 15 | | x -> Format.sprintf "%s-%s" t.file (target_str x) 16 | in 17 | let cmd = 18 | match t.target with 19 | | `Unix -> t.cmd 20 | | x -> Format.sprintf "%s --target=%s" t.cmd (target_str x) 21 | in 22 | let cmd = match t.args with None -> cmd | Some a -> cmd ^ " " ^ a in 23 | Format.printf 24 | {| 25 | (rule 26 | (action 27 | (with-stdout-to %s 28 | (with-stderr-to %s.err 29 | (setenv MIRAGE_DEFAULT_TARGET unix 30 | (run ./config.exe %s)))))) 31 | 32 | (rule 33 | (alias runtest) 34 | (package mirage) 35 | (action 36 | (diff %s.expected %s))) 37 | 38 | (rule 39 | (alias runtest) 40 | (package mirage) 41 | (action 42 | (diff %s.err.expected %s.err))) 43 | |} 44 | file file cmd file file file file 45 | 46 | let of_target target = 47 | List.iter gen 48 | [ 49 | v "name" target; 50 | v "opam" target; 51 | v "packages" target; 52 | v "files" target; 53 | v "Makefile" target; 54 | { 55 | file = "Makefile.no-depext"; 56 | cmd = "query Makefile --no-depext"; 57 | args = None; 58 | target; 59 | }; 60 | { 61 | file = "Makefile.depext"; 62 | cmd = "query Makefile --depext"; 63 | target; 64 | args = None; 65 | }; 66 | { file = "x-dune"; cmd = "query dune --dry-run"; target; args = None }; 67 | { file = "x-dune-base"; cmd = "query dune-base"; target; args = None }; 68 | { 69 | file = "x-dune-project"; 70 | cmd = "query dune-project"; 71 | target; 72 | args = None; 73 | }; 74 | { 75 | file = "x-dune-workspace"; 76 | cmd = "query dune-workspace --dry-run --build-dir foo"; 77 | target; 78 | args = None; 79 | }; 80 | ] 81 | 82 | let () = List.iter of_target [ `Unix; `Hvt ] 83 | -------------------------------------------------------------------------------- /lib/functoria/DSL.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type 'a key = 'a Key.key 20 | type 'a value = 'a Key.value 21 | type abstract_key = Key.t 22 | type package = Package.t 23 | type scope = Package.scope 24 | type 'a typ = 'a Type.t 25 | type 'a impl = 'a Impl.t 26 | type abstract_impl = Impl.abstract 27 | type 'a device = ('a, Impl.abstract) Device.t 28 | type context = Key.context 29 | type job = Job.t 30 | type info = Info.t 31 | 32 | let package = Package.v 33 | let ( @-> ) = Type.( @-> ) 34 | let typ = Type.v 35 | let ( $ ) = Impl.( $ ) 36 | let of_device = Impl.of_device 37 | let key = Key.v 38 | let dep = Impl.abstract 39 | let abstract = dep 40 | let if_impl = Impl.if_ 41 | let match_impl = Impl.match_ 42 | 43 | let impl ?packages ?packages_v ?install ?install_v ?keys ?extra_deps ?connect 44 | ?dune ?configure ?files module_name module_type = 45 | of_device 46 | @@ Device.v ?packages ?packages_v ?install ?install_v ?keys ?extra_deps 47 | ?connect ?dune ?configure ?files module_name module_type 48 | 49 | let main ?packages ?packages_v ?keys ?extra_deps module_name ty = 50 | let connect _ = Device.start in 51 | impl ?packages ?packages_v ?keys ?extra_deps ~connect module_name ty 52 | 53 | let foreign ?packages ?packages_v ?keys ?deps module_name ty = 54 | main ?packages ?packages_v ?keys ?extra_deps:deps module_name ty 55 | -------------------------------------------------------------------------------- /lib/functoria/context_cache.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Manage context caches, via the [--context-file ] command-line 20 | argument. *) 21 | 22 | type t 23 | (** The type for cache. *) 24 | 25 | val file : name:string -> 'a Cli.args -> Fpath.t 26 | (** [file ~name args] is the filename of the context cache for the tool [name]. *) 27 | 28 | val empty : t 29 | (** The empty cache. *) 30 | 31 | val is_empty : t -> bool 32 | (** [is_empty t] is empty iff [t] is {!empty}. *) 33 | 34 | val write : Fpath.t -> string array -> unit Action.t 35 | (** [write f argv] writes the context cache in the file [f]. *) 36 | 37 | val read : Fpath.t -> t Action.t 38 | (** [read f] reads the context cache stored in [f]. The result is 39 | [Action.ok empty] if [f] does not exists and [Action.error _] if the cache 40 | contains garbage. *) 41 | 42 | val peek : t -> Key.context Cmdliner.Term.t -> Key.context option 43 | (** [peek t term] is the context obtained by evaluating [term] over the cached 44 | context [t]. *) 45 | 46 | val merge : t -> Key.context Cmdliner.Term.t -> Key.context Cmdliner.Term.t 47 | (** [eval_context t term] is the context obtained by evaluating [term] over the 48 | cached context [t]. *) 49 | 50 | val peek_output : t -> string option 51 | (** [peek_output t] is the evaluation of {!Cli.output} over the cached context 52 | [t]. *) 53 | -------------------------------------------------------------------------------- /lib/functoria/misc.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Rresult 20 | open Astring 21 | 22 | let err_cmdliner ?(usage = false) = function 23 | | Ok x -> `Ok x 24 | | Error s -> `Error (usage, s) 25 | 26 | module type Monoid = sig 27 | type t 28 | 29 | val empty : t 30 | val union : t -> t -> t 31 | end 32 | 33 | (* {Misc informations} *) 34 | 35 | module Name = struct 36 | module Opam = struct 37 | type t = string 38 | 39 | let to_string = Fun.id 40 | end 41 | 42 | let opamify s = 43 | let b = Buffer.create (String.length s) in 44 | String.iter 45 | (function 46 | | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-') as c -> 47 | Buffer.add_char b c 48 | | '.' -> Buffer.add_char b '_' 49 | | _ -> ()) 50 | s; 51 | let s' = Buffer.contents b in 52 | if String.length s' = 0 then raise (Invalid_argument s); 53 | s' 54 | 55 | let ocamlify s = 56 | let b = Buffer.create (String.length s) in 57 | String.iter 58 | (function 59 | | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_') as c -> 60 | Buffer.add_char b c 61 | | '-' | '.' -> Buffer.add_char b '_' 62 | | _ -> ()) 63 | s; 64 | let s' = Buffer.contents b in 65 | if String.length s' = 0 || ('0' <= s'.[0] && s'.[0] <= '9') then 66 | raise (Invalid_argument s); 67 | s' 68 | end 69 | -------------------------------------------------------------------------------- /lib/functoria/install.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type t 20 | 21 | val v : ?bin:(Fpath.t * Fpath.t) list -> ?etc:Fpath.t list -> unit -> t 22 | (** [v ~bin:\[(src,dst),...\] ~etc ()] is the installation of [src] as [dst] as 23 | binary files, and [etc] as configuration/artifact. *) 24 | 25 | val union : t -> t -> t 26 | (** [union a b] merge to sets of installation rules. *) 27 | 28 | val empty : t 29 | (** [empty] is the installation of nothing. *) 30 | 31 | val pp : t Fmt.t 32 | (** Print the .install rules to install [t] *) 33 | 34 | val pp_opam : ?subdir:Fpath.t -> unit -> t Fmt.t 35 | (** Print the opam rules to install [t]. If [~subdir] is provided, this will be 36 | used as prefix (i.e. if your unikernel is in the "tutorial/hello/" 37 | subdirectory (which is passed as [~subdir], the install instructions will 38 | use [cp tutorial/hello/dist/hello.hvt %{bin}%/hello.hvt]). *) 39 | 40 | val dune : 41 | context_name_for_bin:string -> context_name_for_etc:string -> t -> Dune.t 42 | (** [dune ~context_name_for_bin ~context_name_for_etc ()] is the dune rules to 43 | promote installed files back in the source tree. A context-name is required 44 | for [bin] and [etc] artifacts. The first one should be the cross-compiler 45 | context and the second one should be the host's compiler context. *) 46 | 47 | val dump : t Fmt.t 48 | (** Dump installation rules. *) 49 | -------------------------------------------------------------------------------- /lib/functoria/engine.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Functoria engine. *) 20 | 21 | val if_keys : Impl.abstract -> Key.Set.t 22 | (** [if_keys t] is the set of [if] keys in the graph [t]. *) 23 | 24 | val all_keys : Impl.abstract -> Key.Set.t 25 | (** [all_keys t] is the set of keys in the graph [t]. *) 26 | 27 | val packages : Impl.abstract -> Package.t list Key.value 28 | (** [packages t] is the set of packages in the graph [t]. *) 29 | 30 | val install : Info.t -> Impl.abstract -> Install.t Key.value 31 | (** [install i t] is the set of files installed by the graph [t]. *) 32 | 33 | val files : Info.t -> Impl.abstract -> Fpath.Set.t 34 | (** [files i t] is the list of files generated configure-time. *) 35 | 36 | val dune : Info.t -> Impl.abstract -> Dune.stanza list 37 | (** [dune i t] is the list of dune stanzas needed to build the project [t] with 38 | the build information [i]. *) 39 | 40 | (** {2 Triggering Hooks} *) 41 | 42 | type t = Device.Graph.t 43 | (** The type for key graphs. *) 44 | 45 | val configure : Info.t -> t -> unit Action.t 46 | (** [configure i t] calls all the configuration hooks for each of the 47 | implementations appearing in [t], in topological order. Use the build 48 | information [i]. *) 49 | 50 | val connect : ?init:'a Impl.t list -> Info.t -> t -> unit Action.t 51 | (** [connect ?init i t] generates the [connect] functions in [main.ml], for each 52 | of the implementations appearing [t], in topological order. Use build 53 | information [i]. *) 54 | -------------------------------------------------------------------------------- /lib/functoria/type.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Representation of module signatures. *) 20 | 21 | (** The type for values representing module types. *) 22 | type 'a t = Type : 'a -> 'a t | Function : 'a t * 'b t -> ('a -> 'b) t 23 | 24 | val v : 'a -> 'a t 25 | (** [type t] is a value representing the module type [t]. *) 26 | 27 | val ( @-> ) : 'a t -> 'b t -> ('a -> 'b) t 28 | (** [x @-> y] is the functor type from the module signature [x] to the module 29 | signature [y]. This corresponds to prepending a parameter to the list of 30 | functor parameters. For example: 31 | 32 | {[ 33 | kv_ro @-> ip @-> kv_ro 34 | ]} 35 | 36 | This describes a functor type that accepts two arguments -- a [kv_ro] and an 37 | [ip] device -- and returns a [kv_ro]. *) 38 | 39 | val is_functor : _ t -> bool 40 | (** [is_functor t] is true if [t] has type [(a -> b) t]. *) 41 | 42 | val pp : 'a t Fmt.t 43 | (** [pp] is the pretty printer for module types. *) 44 | 45 | (** {1 Useful module types} *) 46 | 47 | type job 48 | (** Type for job values. *) 49 | 50 | val job : job t 51 | (** [job] is the signature for user's application main module. *) 52 | 53 | type argv 54 | (** The type for command-line arguments, similar to the usual [Sys.argv]. *) 55 | 56 | val argv : argv t 57 | (** [argv] is a value representing {!type-argv} module types. *) 58 | 59 | type info 60 | (** The type for application about the application being built. *) 61 | 62 | val info : info t 63 | (** [info] is a value representing {!type-info} module types. *) 64 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_http.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_pclock 3 | open Mirage_impl_misc 4 | open Mirage_impl_conduit 5 | open Mirage_impl_resolver 6 | open Mirage_impl_tcp 7 | open Mirage_impl_mimic 8 | 9 | type http = HTTP 10 | 11 | let http = Type.v HTTP 12 | 13 | type http_client = HTTP_client 14 | 15 | let http_client = Type.v HTTP_client 16 | 17 | let connect err _i modname = function 18 | | [ conduit ] -> Fmt.str "Lwt.return (%s.listen %s)" modname conduit 19 | | _ -> failwith (connect_err err 1) 20 | 21 | let cohttp_server = 22 | let packages = [ package ~min:"4.0.0" ~max:"6.0.0" "cohttp-mirage" ] in 23 | impl ~packages ~connect:(connect "http") "Cohttp_mirage.Server.Make" 24 | (conduit @-> http) 25 | 26 | let cohttp_server conduit = cohttp_server $ conduit 27 | 28 | let cohttp_client = 29 | let packages = [ package ~min:"4.0.0" ~max:"6.0.0" "cohttp-mirage" ] in 30 | let connect _i modname = function 31 | | [ _pclock; resolver; conduit ] -> 32 | Fmt.str "Lwt.return (%s.ctx %s %s)" modname resolver conduit 33 | | _ -> failwith (connect_err "http" 2) 34 | in 35 | impl ~packages ~connect "Cohttp_mirage.Client.Make" 36 | (pclock @-> resolver @-> conduit @-> http_client) 37 | 38 | let cohttp_client ?(pclock = default_posix_clock) resolver conduit = 39 | cohttp_client $ pclock $ resolver $ conduit 40 | 41 | let httpaf_server conduit = 42 | let packages = [ package "httpaf-mirage" ] in 43 | let extra_deps = [ dep conduit ] in 44 | impl ~packages ~connect:(connect "httpaf") ~extra_deps 45 | "Httpaf_mirage.Server_with_conduit" http 46 | 47 | type http_server = HTTP_server 48 | 49 | let http_server = Type.v HTTP_server 50 | 51 | let paf_server port = 52 | let connect _ modname = function 53 | | [ tcpv4v6 ] -> 54 | Fmt.str {ocaml|%s.init ~port:%a %s|ocaml} modname Key.serialize_call 55 | (Key.v port) tcpv4v6 56 | | _ -> assert false 57 | in 58 | let packages = 59 | [ package "paf" ~sublibs:[ "mirage" ] ~min:"0.3.0" ~max:"0.4.0" ] 60 | in 61 | let keys = [ Key.v port ] in 62 | impl ~connect ~packages ~keys "Paf_mirage.Make" (tcpv4v6 @-> http_server) 63 | 64 | type alpn_client = ALPN_client 65 | 66 | let alpn_client = Type.v ALPN_client 67 | 68 | let paf_client = 69 | let packages = [ package "http-mirage-client" ~min:"0.0.1" ~max:"0.1.0" ] in 70 | let connect _ modname = function 71 | | [ _pclock; _tcpv4v6; ctx ] -> 72 | Fmt.str {ocaml|%s.connect %s|ocaml} modname ctx 73 | | _ -> assert false 74 | in 75 | impl ~connect ~packages "Http_mirage_client.Make" 76 | (pclock @-> tcpv4v6 @-> mimic @-> alpn_client) 77 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_kv.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Astring 3 | module Key = Mirage_key 4 | 5 | type ro = RO 6 | 7 | let ro = Type.v RO 8 | 9 | let crunch dirname = 10 | let is_valid = function 11 | | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' -> true 12 | | _ -> false 13 | in 14 | let modname = String.filter is_valid dirname in 15 | let name = "Static_" ^ String.Ascii.lowercase modname in 16 | let packages = 17 | [ 18 | package ~min:"3.0.0" ~max:"4.0.0" "mirage-kv-mem"; 19 | package ~min:"3.1.0" ~max:"4.0.0" ~build:true "crunch"; 20 | ] 21 | in 22 | let connect _ modname _ = Fmt.str "%s.connect ()" modname in 23 | let dune _i = 24 | let dir = Fpath.(v dirname) in 25 | let file ext = Fpath.(v (String.Ascii.lowercase name) + ext) in 26 | let ml = file "ml" in 27 | let mli = file "mli" in 28 | let dune = 29 | Dune.stanzaf 30 | {| 31 | (rule 32 | (targets %a %a) 33 | (deps (source_tree %a)) 34 | (action 35 | (run ocaml-crunch -o %a %a))) 36 | |} 37 | Fpath.pp ml Fpath.pp mli Fpath.pp dir Fpath.pp ml Fpath.pp dir 38 | in 39 | [ dune ] 40 | in 41 | impl ~packages ~connect ~dune name ro 42 | 43 | let direct_kv_ro dirname = 44 | let packages = [ package ~min:"2.1.0" ~max:"3.0.0" "mirage-kv-unix" ] in 45 | let connect _ modname _names = Fmt.str "%s.connect \"%s\"" modname dirname in 46 | impl ~packages ~connect "Mirage_kv_unix" ro 47 | 48 | let direct_kv_ro dirname = 49 | match_impl 50 | Key.(value target) 51 | [ 52 | (`Xen, crunch dirname); 53 | (`Qubes, crunch dirname); 54 | (`Virtio, crunch dirname); 55 | (`Hvt, crunch dirname); 56 | (`Spt, crunch dirname); 57 | (`Muen, crunch dirname); 58 | (`Genode, crunch dirname); 59 | ] 60 | ~default:(direct_kv_ro dirname) 61 | 62 | type rw = RW 63 | 64 | let rw = Type.v RW 65 | 66 | let direct_kv_rw dirname = 67 | let packages = [ package ~min:"2.1.0" ~max:"3.0.0" "mirage-kv-unix" ] in 68 | let connect _ modname _names = Fmt.str "%s.connect \"%s\"" modname dirname in 69 | impl ~packages ~connect "Mirage_kv_unix" rw 70 | 71 | let mem_kv_rw_config = 72 | let packages = [ package ~min:"3.0.0" ~max:"4.0.0" "mirage-kv-mem" ] in 73 | let connect _ modname _names = Fmt.str "%s.connect ()" modname in 74 | impl ~packages ~connect "Mirage_kv_mem.Make" (Mirage_impl_pclock.pclock @-> rw) 75 | 76 | let mem_kv_rw ?(clock = Mirage_impl_pclock.default_posix_clock) () = 77 | mem_kv_rw_config $ clock 78 | 79 | (** generic kv_ro. *) 80 | 81 | let generic_kv_ro ?group ?(key = Key.value @@ Key.kv_ro ?group ()) dir = 82 | match_impl key 83 | [ (`Crunch, crunch dir); (`Direct, direct_kv_ro dir) ] 84 | ~default:(direct_kv_ro dir) 85 | -------------------------------------------------------------------------------- /test/functoria/e2e/build.t: -------------------------------------------------------------------------------- 1 | Build an application. 2 | 3 | $ ./test.exe configure --file app/config.ml 4 | $ ./test.exe build -v --file app/config.ml 5 | test.exe: [INFO] run: build: 6 | { "context" = ; 7 | "config_file" = app/config.ml; 8 | "output" = None; 9 | "dry_run" = false } 10 | test.exe: [INFO] Generating: app/test/dune-workspace.config (base) 11 | test.exe: [INFO] Generating: dune-project (base) 12 | test.exe: [INFO] Generating: app/dune.config (base) 13 | config.exe: [INFO] reading cache app/test/context 14 | config.exe: [INFO] Name noop 15 | Keys 16 | hello=Hello World! (default), 17 | vote=cat (default), 18 | warn_error=false (default) 19 | config.exe: [INFO] dune build --root . 20 | $ ls -a app/ 21 | . 22 | .. 23 | app.ml 24 | config.ml 25 | dist 26 | dune 27 | dune.build 28 | dune.config 29 | main.exe 30 | test 31 | $ ls -a app/test 32 | . 33 | .. 34 | context 35 | dune-workspace.config 36 | key_gen.ml 37 | main.ml 38 | noop.opam 39 | vote 40 | warn_error 41 | $ ./app/main.exe 42 | Success: vote=cat hello=Hello World! 43 | $ ./test.exe clean --file app/config.ml 44 | $ ls -a app/ 45 | . 46 | .. 47 | app.ml 48 | config.ml 49 | 50 | Test `--output`: 51 | 52 | $ ./test.exe configure --file app/config.ml -o toto 53 | $ ./test.exe build -v --file app/config.ml 54 | test.exe: [INFO] run: build: 55 | { "context" = ; 56 | "config_file" = app/config.ml; 57 | "output" = None; 58 | "dry_run" = false } 59 | test.exe: [INFO] Generating: app/test/dune-workspace.config (base) 60 | test.exe: [INFO] Generating: dune-project (base) 61 | test.exe: [INFO] Generating: app/dune.config (base) 62 | config.exe: [INFO] reading cache app/test/context 63 | config.exe: [INFO] Name noop 64 | Keys 65 | hello=Hello World! (default), 66 | vote=cat (default), 67 | warn_error=false (default)Output toto 68 | config.exe: [INFO] dune build --root . 69 | $ ls -a app/ 70 | . 71 | .. 72 | app.ml 73 | config.ml 74 | dist 75 | dune 76 | dune.build 77 | dune.config 78 | test 79 | toto.exe 80 | $ ls -a app/test 81 | . 82 | .. 83 | context 84 | dune-workspace.config 85 | key_gen.ml 86 | noop.opam 87 | toto.ml 88 | vote 89 | warn_error 90 | $ ./app/toto.exe 91 | Success: vote=cat hello=Hello World! 92 | $ ./test.exe clean --file app/config.ml 93 | $ ls -a app/ 94 | . 95 | .. 96 | app.ml 97 | config.ml 98 | -------------------------------------------------------------------------------- /test/functoria/e2e/clean.t: -------------------------------------------------------------------------------- 1 | Make sure that clean remove everything: 2 | 3 | $ ./test.exe configure --file app/config.ml 4 | $ ls -a app 5 | . 6 | .. 7 | app.ml 8 | config.ml 9 | dist 10 | dune 11 | dune.build 12 | dune.config 13 | test 14 | $ ls -a app/test 15 | . 16 | .. 17 | context 18 | dune-workspace.config 19 | key_gen.ml 20 | main.ml 21 | noop.opam 22 | vote 23 | warn_error 24 | $ ./test.exe clean -v --file app/config.ml 25 | test.exe: [INFO] run: clean: 26 | { "context" = ; 27 | "config_file" = app/config.ml; 28 | "output" = None; 29 | "dry_run" = false } 30 | test.exe: [INFO] Generating: app/test/dune-workspace.config (base) 31 | test.exe: [INFO] Generating: dune-project (base) 32 | test.exe: [INFO] Generating: app/dune.config (base) 33 | config.exe: [INFO] reading cache app/test/context 34 | config.exe: [INFO] Name noop 35 | Keys 36 | hello=Hello World! (default), 37 | vote=cat (default), 38 | warn_error=false (default) 39 | test.exe: [INFO] Skipped ./app 40 | test.exe: [INFO] Skipped ./help.exe 41 | test.exe: [INFO] Skipped ./lib 42 | test.exe: [INFO] Skipped ./test.exe 43 | $ ls -a app 44 | . 45 | .. 46 | app.ml 47 | config.ml 48 | 49 | Check that clean works with `--output`: 50 | 51 | $ ./test.exe configure --file app/config.ml --output=toto 52 | $ ls -a app 53 | . 54 | .. 55 | app.ml 56 | config.ml 57 | dist 58 | dune 59 | dune.build 60 | dune.config 61 | test 62 | $ ls -a app/test 63 | . 64 | .. 65 | context 66 | dune-workspace.config 67 | key_gen.ml 68 | noop.opam 69 | toto.ml 70 | vote 71 | warn_error 72 | $ ./test.exe clean -v --file app/config.ml 73 | test.exe: [INFO] run: clean: 74 | { "context" = ; 75 | "config_file" = app/config.ml; 76 | "output" = None; 77 | "dry_run" = false } 78 | test.exe: [INFO] Generating: app/test/dune-workspace.config (base) 79 | test.exe: [INFO] Generating: dune-project (base) 80 | test.exe: [INFO] Generating: app/dune.config (base) 81 | config.exe: [INFO] reading cache app/test/context 82 | config.exe: [INFO] Name noop 83 | Keys 84 | hello=Hello World! (default), 85 | vote=cat (default), 86 | warn_error=false (default)Output toto 87 | test.exe: [INFO] Skipped ./app 88 | test.exe: [INFO] Skipped ./help.exe 89 | test.exe: [INFO] Skipped ./lib 90 | test.exe: [INFO] Skipped ./test.exe 91 | $ ls -a app 92 | . 93 | .. 94 | app.ml 95 | config.ml 96 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_misc.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Astring 3 | open Action.Syntax 4 | 5 | let src = Logs.Src.create "mirage" ~doc:"mirage cli tool" 6 | 7 | module Log = (val Logs.src_log src : Logs.LOG) 8 | 9 | let get_target i = Mirage_key.(get (Functoria.Info.context i) target) 10 | 11 | let connect_err name number = 12 | Fmt.str "The %s connect expects exactly %d argument%s" name number 13 | (if number = 1 then "" else "s") 14 | 15 | let pp_key fmt k = Mirage_key.serialize_call fmt (Mirage_key.v k) 16 | 17 | let query_ocamlfind ?(recursive = false) ?(format = "%p") ?predicates libs = 18 | let open Bos in 19 | let flag = if recursive then Cmd.v "-recursive" else Cmd.empty 20 | and format = Cmd.of_list [ "-format"; format ] 21 | and predicate = 22 | match predicates with None -> [] | Some x -> [ "-predicates"; x ] 23 | and q = "query" in 24 | let cmd = 25 | Cmd.( 26 | v "ocamlfind" % q %% flag %% format %% of_list predicate %% of_list libs) 27 | in 28 | let+ out = Action.run_cmd_out cmd in 29 | String.cuts ~sep:"\n" ~empty:false out 30 | 31 | let opam_prefix = 32 | let cmd = Bos.Cmd.(v "opam" % "config" % "var" % "prefix") in 33 | lazy (Action.run_cmd_out cmd) 34 | 35 | (* Implement something similar to the @name/file extended names of findlib. *) 36 | let rec expand_name ~lib param = 37 | match String.cut param ~sep:"@" with 38 | | None -> param 39 | | Some (prefix, name) -> ( 40 | match String.cut name ~sep:"/" with 41 | | None -> prefix ^ Fpath.(to_string (v lib / name)) 42 | | Some (name, rest) -> 43 | let rest = expand_name ~lib rest in 44 | prefix ^ Fpath.(to_string (v lib / name / rest))) 45 | 46 | (* Get the linker flags for any extra C objects we depend on. 47 | * This is needed when building a Xen/Solo5 image as we do the link manually. *) 48 | let extra_c_artifacts target pkgs = 49 | let* prefix = Lazy.force opam_prefix in 50 | let lib = prefix ^ "/lib" in 51 | let format = Fmt.str "%%d\t%%(%s_linkopts)" target 52 | and predicates = "native" in 53 | let* data = query_ocamlfind ~recursive:true ~format ~predicates pkgs in 54 | let r = 55 | List.fold_left 56 | (fun acc line -> 57 | match String.cut line ~sep:"\t" with 58 | | None -> acc 59 | | Some (dir, ldflags) -> 60 | if ldflags <> "" then 61 | let ldflags = String.cuts ldflags ~sep:" " in 62 | let ldflags = List.map (expand_name ~lib) ldflags in 63 | acc @ (("-L" ^ dir) :: ldflags) 64 | else acc) 65 | [] data 66 | in 67 | Action.ok r 68 | 69 | let terminal () = 70 | let dumb = try Sys.getenv "TERM" = "dumb" with Not_found -> true in 71 | let isatty = 72 | try Unix.(isatty (descr_of_out_channel Stdlib.stdout)) 73 | with Unix.Unix_error _ -> false 74 | in 75 | (not dumb) && isatty 76 | -------------------------------------------------------------------------------- /lib/functoria/job.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | let src = Logs.Src.create "functoria" ~doc:"functoria library" 20 | 21 | module Log = (val Logs.src_log src : Logs.LOG) 22 | open Astring 23 | 24 | type t = JOB 25 | 26 | let t = Type.v JOB 27 | 28 | (* Noop, the job that does nothing. *) 29 | let noop = Impl.v "Unit" t 30 | 31 | module Keys = struct 32 | let configure ~file i = 33 | Log.info (fun m -> m "Generating: %a (keys)" Fpath.pp file); 34 | Action.with_output ~path:file ~purpose:"key_gen file" (fun ppf -> 35 | let keys = Key.Set.of_list @@ Info.keys i in 36 | let pp_var = Key.serialize (Info.context i) in 37 | Fmt.pf ppf "@[%a@]@." Fmt.(iter Key.Set.iter pp_var) keys; 38 | let runvars = Key.Set.elements (Key.filter_stage `Run keys) in 39 | let pp_runvar ppf v = Fmt.pf ppf "%s_t" (Key.ocaml_name v) in 40 | let pp_names ppf v = Fmt.pf ppf "%S" (Key.name v) in 41 | Fmt.pf ppf "let runtime_keys = List.combine %a %a@." 42 | Fmt.Dump.(list pp_runvar) 43 | runvars 44 | Fmt.Dump.(list pp_names) 45 | runvars) 46 | end 47 | 48 | let keys ?(runtime_package = "functoria-runtime") 49 | ?(runtime_modname = "Functoria_runtime") (argv : Argv.t Impl.t) = 50 | let packages = [ Package.v runtime_package ] in 51 | let extra_deps = [ Impl.abstract argv ] in 52 | let key_gen = Key.module_name in 53 | let file = Fpath.(v (String.Ascii.lowercase key_gen) + "ml") in 54 | let configure = Keys.configure ~file in 55 | let files _ = [ file ] in 56 | let connect info impl_name = function 57 | | [ argv ] -> 58 | Fmt.str "return (%s.with_argv (List.map fst %s.runtime_keys) %S %s)" 59 | runtime_modname impl_name (Info.name info) argv 60 | | _ -> failwith "The keys connect should receive exactly one argument." 61 | in 62 | Impl.v ~files ~configure ~packages ~extra_deps ~connect key_gen t 63 | -------------------------------------------------------------------------------- /test/functoria/errors/run.t: -------------------------------------------------------------------------------- 1 | Configure failure 2 | $ ./test.exe configure --vote=dog 3 | configuration file config.ml missing 4 | [1] 5 | 6 | Build failure 7 | $ ./test.exe build --vote=dog 8 | configuration file config.ml missing 9 | [1] 10 | 11 | 12 | Query failure 13 | $ ./test.exe query --vote=dog 14 | configuration file config.ml missing 15 | [1] 16 | 17 | 18 | Describe failure 19 | $ ./test.exe describe --vote=dog 20 | configuration file config.ml missing 21 | [1] 22 | 23 | Clean does not fail 24 | $ ./test.exe clean --vote=dog 25 | 26 | Help does not fail 27 | $ ./test.exe help --man-format=plain 28 | NAME 29 | test - The test application builder 30 | 31 | SYNOPSIS 32 | test [COMMAND] … 33 | 34 | DESCRIPTION 35 | The test application builder. It glues together a set of libraries and 36 | configuration (e.g. network and storage) into a standalone unikernel 37 | or UNIX binary. 38 | 39 | Use test help for more information on a specific command. 40 | 41 | COMMANDS 42 | build [OPTION]… 43 | Build a test application. 44 | 45 | clean [OPTION]… 46 | Clean the files produced by test for a given application. 47 | 48 | configure [OPTION]… 49 | Configure a test application. 50 | 51 | describe [OPTION]… 52 | Describe a test application. 53 | 54 | help [--man-format=FMT] [OPTION]… [TOPIC] 55 | Display help about test commands. 56 | 57 | query [OPTION]… [INFO] 58 | Query information about the test application. 59 | 60 | COMMON OPTIONS 61 | --color=WHEN (absent=auto) 62 | Colorize the output. WHEN must be one of auto, always or never. 63 | 64 | --help[=FMT] (default=auto) 65 | Show this help in format FMT. The value FMT must be one of auto, 66 | pager, groff or plain. With auto, the format is pager or plain 67 | whenever the TERM env var is dumb or undefined. 68 | 69 | -q, --quiet 70 | Be quiet. Takes over -v and --verbosity. 71 | 72 | -v, --verbose 73 | Increase verbosity. Repeatable, but more than twice does not bring 74 | more. 75 | 76 | --verbosity=LEVEL (absent=warning) 77 | Be more or less verbose. LEVEL must be one of quiet, error, 78 | warning, info or debug. Takes over -v. 79 | 80 | --version 81 | Show version information. 82 | 83 | EXIT STATUS 84 | test exits with the following status: 85 | 86 | 0 on success. 87 | 88 | 123 on indiscriminate errors reported on standard error. 89 | 90 | 124 on command line parsing errors. 91 | 92 | 125 on unexpected internal errors (bugs). 93 | 94 | -------------------------------------------------------------------------------- /scripts/ec2.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # Build an EC2 bundle and upload/register it to Amazon. 3 | 4 | 5 | NAME=mirage 6 | BUCKET=mirage-deployment 7 | REGION=us-west-2 8 | while getopts "hn:b:r:k:" arg; do 9 | case $arg in 10 | h) 11 | echo "usage: $0 [-h] [-n ] [-b ] [-r ] -k " 12 | echo "" 13 | echo ": Name of the kernel file (e.g. mir-www.xen)" 14 | echo ": the application name to use (default: ${NAME})" 15 | echo ": the S3 bucket to upload to (default: ${BUCKET})" 16 | echo ": the EC2 region to register AMI in (default: ${REGION})" 17 | 18 | echo Remember to set each of the following environment variables in your 19 | echo environment before running this script: 20 | echo EC2_ACCESS, EC2_ACCESS_SECRET, EC2_CERT, EC2_PRIVATE_KEY 21 | exit 1 ;; 22 | n) NAME=$OPTARG ;; 23 | b) BUCKET=$OPTARG ;; 24 | r) REGION=$OPTARG ;; 25 | k) APP=$OPTARG ;; 26 | esac 27 | done 28 | 29 | if [ ! -e "$APP" ]; then 30 | echo "Must specify a unikernel file with the [-k] flag." 31 | echo "Run '$0 -h' for full option list." 32 | exit 1 33 | fi 34 | 35 | # Make name unique to avoid registration clashes 36 | NAME=${NAME}-`date +%s` 37 | MNT=/tmp/mirage-ec2 38 | SUDO=sudo 39 | IMG=${NAME}.img 40 | 41 | echo Name : ${NAME} 42 | echo Bucket: ${BUCKET} 43 | echo Region: ${REGION} 44 | 45 | set -e 46 | # KERNEL is ec2-describe-images -o amazon --region ${REGION} -F "manifest-location=*pv-grub-hd0*" -F "architecture=x86_64" | tail -1 | cut -f2 47 | # Also obtained from http://docs.aws.amazon.com/AWSEC2/latest/UserGuide/UserProvidedKernels.html 48 | KERNEL=aki-fc8f11cc #us-west-2 49 | 50 | ${SUDO} mkdir -p ${MNT} 51 | rm -f ${IMG} 52 | dd if=/dev/zero of=${IMG} bs=1M count=5 53 | ${SUDO} mke2fs -F -j ${IMG} 54 | ${SUDO} mount -o loop ${IMG} ${MNT} 55 | 56 | ${SUDO} mkdir -p ${MNT}/boot/grub 57 | echo default 0 > menu.lst 58 | echo timeout 1 >> menu.lst 59 | echo title Mirage >> menu.lst 60 | echo " root (hd0)" >> menu.lst 61 | echo " kernel /boot/mirage-os.gz" >> menu.lst 62 | ${SUDO} mv menu.lst ${MNT}/boot/grub/menu.lst 63 | ${SUDO} sh -c "gzip -c $APP > ${MNT}/boot/mirage-os.gz" 64 | ${SUDO} umount -d ${MNT} 65 | 66 | rm -rf ec2_tmp 67 | mkdir ec2_tmp 68 | 69 | echo Bundling image... 70 | ec2-bundle-image -i ${IMG} -k ${EC2_PRIVATE_KEY} -c ${EC2_CERT} -u ${EC2_USER} -d ec2_tmp -r x86_64 --kernel ${KERNEL} 71 | echo Uploading image... 72 | ec2-upload-bundle -b ${BUCKET} -m ec2_tmp/${IMG}.manifest.xml -a ${EC2_ACCESS} -s ${EC2_ACCESS_SECRET} --location ${REGION} 73 | echo Registering image... 74 | id=`ec2-register ${BUCKET}/${IMG}.manifest.xml -n ${NAME} --region ${REGION} | awk '{print $2}'` 75 | rm -rf ec2_tmp 76 | rm -f ${IMG} 77 | 78 | echo You can now start this instance via: 79 | echo ec2-run-instances --region ${REGION} $id 80 | echo "" 81 | echo Don\'t forget to customise this with a security group, as the 82 | echo default one won\'t let any inbound traffic in. 83 | -------------------------------------------------------------------------------- /lib/functoria/info.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Information about the final application. *) 20 | 21 | type t 22 | (** The type for information about the final application. *) 23 | 24 | val config_file : t -> Fpath.t 25 | (** [config_file t] is the configuration file of the application. *) 26 | 27 | val name : t -> string 28 | (** [name t] is the name of the application. *) 29 | 30 | val main : t -> Fpath.t 31 | (** [main t] is the name of the main application file. *) 32 | 33 | val output : t -> string option 34 | (** [output t] is the name of [t]'s output. Derived from {!name} if not set. *) 35 | 36 | val with_output : t -> string -> t 37 | (** [with_output t o] is similar to [t] but with the output set to [Some o]. *) 38 | 39 | val libraries : t -> string list 40 | (** [libraries t] are the direct OCamlfind dependencies. *) 41 | 42 | val packages : t -> Package.t list 43 | (** [packages t] are the opam package dependencies by the project. *) 44 | 45 | val opam : 46 | t -> 47 | extra_repo:(string * string) list -> 48 | install:Install.t -> 49 | opam_name:string -> 50 | Opam.t 51 | (** [opam scope t] is [t]'opam file to install in the [scope] context.*) 52 | 53 | val keys : t -> Key.t list 54 | (** [keys t] are the keys declared by the project. *) 55 | 56 | val context : t -> Key.context 57 | (** [parsed t] is a value representing the command-line argument being parsed. *) 58 | 59 | val get : t -> 'a Key.key -> 'a 60 | (** [get i k] is the value associated with [k] in [context i]. *) 61 | 62 | val v : 63 | ?config_file:Fpath.t -> 64 | packages:Package.t list -> 65 | keys:Key.t list -> 66 | context:Key.context -> 67 | ?configure_cmd:string -> 68 | ?pre_build_cmd:(Fpath.t option -> string) -> 69 | ?lock_location:(Fpath.t option -> string -> string) -> 70 | build_cmd:string -> 71 | src:[ `Auto | `None | `Some of string ] -> 72 | string -> 73 | t 74 | (** [create context n r] contains information about the application being built. *) 75 | 76 | val pp : bool -> t Fmt.t 77 | 78 | (** {1 Devices} *) 79 | 80 | val t : t Type.t 81 | -------------------------------------------------------------------------------- /test/functoria/e2e/help.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Jeremy Yallop 3 | * Copyright (c) 2021 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Astring 19 | 20 | (* cut a man page into sections *) 21 | let by_sections s = 22 | let lines = String.cuts ~sep:"\n" s in 23 | let return l = 24 | match List.rev l with [] -> assert false | h :: t -> (h, t) 25 | in 26 | let rec aux current sections = function 27 | | [] -> List.rev (return current :: sections) 28 | | h :: t -> 29 | if 30 | String.length h > 1 31 | && String.for_all (fun x -> Char.Ascii.(is_upper x || is_white x)) h 32 | then aux [ h ] (return current :: sections) t 33 | else aux (h :: current) sections t 34 | in 35 | aux [ "INIT" ] [] lines 36 | 37 | let sections = [ "CONFIGURE OPTIONS"; "APPLICATION OPTIONS"; "COMMON OPTIONS" ] 38 | 39 | let read file = 40 | let ic = open_in_bin file in 41 | let str = really_input_string ic (in_channel_length ic) in 42 | close_in ic; 43 | by_sections str 44 | 45 | let err_usage () = 46 | Fmt.pr "[usage]: ./help.exe [diff|show] PARAMS\n"; 47 | exit 1 48 | 49 | let () = 50 | if Array.length Sys.argv <> 4 then err_usage () 51 | else 52 | match Sys.argv.(1) with 53 | | "diff" -> 54 | let s1 = read Sys.argv.(2) in 55 | let s2 = read Sys.argv.(3) in 56 | List.iter 57 | (fun name -> 58 | match (List.assoc_opt name s1, List.assoc_opt name s2) with 59 | | Some s1, Some s2 -> 60 | if List.length s1 <> List.length s2 then 61 | Fmt.failwith "Number of lines in %S differs" name 62 | else 63 | List.iter2 64 | (fun s1 s2 -> 65 | if s1 <> s2 then 66 | Fmt.failwith "Lines in section %S differ:\n %S\n %S\n" 67 | name s1 s2) 68 | s1 s2 69 | | _ -> Fmt.failwith "Section %S differs" name) 70 | sections 71 | | "show" -> ( 72 | let s1 = read Sys.argv.(2) in 73 | let name = Sys.argv.(3) in 74 | match List.assoc_opt name s1 with 75 | | None -> () 76 | | Some s -> List.iter print_endline s) 77 | | _ -> err_usage () 78 | -------------------------------------------------------------------------------- /test/functoria/e2e/configure.t: -------------------------------------------------------------------------------- 1 | Check that configure generates the file in the right dir when `--file` 2 | is passed: 3 | 4 | $ ./test.exe configure -v --file app/config.ml 5 | test.exe: [INFO] run: configure: 6 | { "args" = 7 | { "context" = ; 8 | "config_file" = app/config.ml; 9 | "output" = None; 10 | "dry_run" = false }; 11 | "depext" = true } 12 | test.exe: [INFO] Generating: app/test/dune-workspace.config (base) 13 | test.exe: [INFO] Generating: dune-project (base) 14 | test.exe: [INFO] Generating: app/dune.config (base) 15 | test.exe: [INFO] Preserving arguments in app/test/context: 16 | [|"./test.exe"; "configure"; "-v"; "--file"; 17 | "app/config.ml"|] 18 | test.exe: [INFO] Set-up config skeleton. 19 | config.exe: [INFO] reading cache app/test/context 20 | config.exe: [INFO] Name noop 21 | Keys 22 | hello=Hello World! (default), 23 | vote=cat (default), 24 | warn_error=false (default) 25 | config.exe: [INFO] Generating: noop.opam (opam) 26 | config.exe: [INFO] in dir { "context" = ; 27 | "config_file" = app/config.ml; 28 | "output" = None; 29 | "dry_run" = false } 30 | config.exe: [INFO] Generating: main.ml (main file) 31 | config.exe: [INFO] Generating: key_gen.ml (keys) 32 | config.exe: [INFO] Generating: dune.build (dune.build) 33 | config.exe: [INFO] Generating: dune-workspace (dune-workspace) 34 | config.exe: [INFO] Generating: dune-project (dune-project) 35 | config.exe: [INFO] Generating: dune (dune.dist) 36 | $ ls -a app/ 37 | . 38 | .. 39 | app.ml 40 | config.ml 41 | dist 42 | dune 43 | dune.build 44 | dune.config 45 | test 46 | $ ls -a app/test 47 | . 48 | .. 49 | context 50 | dune-workspace.config 51 | key_gen.ml 52 | main.ml 53 | noop.opam 54 | vote 55 | warn_error 56 | $ ./test.exe clean --file app/config.ml 57 | 58 | Check that configure create the correctcontext file: 59 | 60 | $ ./test.exe configure --file=app/config.ml 61 | $ cat app/test/context 62 | configure 63 | --file=app/config.ml 64 | $ rm -rf custom_build_ 65 | 66 | $ ./test.exe configure --file=app/config.ml 67 | $ cat app/test/context 68 | configure 69 | --file=app/config.ml 70 | $ ./test.exe clean --file=app/config.ml 71 | 72 | Check that `test help configure` and `test configure --help` have the 73 | same output. 74 | 75 | $ ./test.exe help configure --file=app/config.ml --help=plain > h1 76 | $ ./test.exe configure --help=plain --file=app/config.ml > h2 77 | $ ./help.exe diff h1 h2 78 | 79 | Check that `test help configure` works when no config.ml file is present. 80 | 81 | $ ./test.exe configure --help=plain > h0 82 | $ ./help.exe show h0 SYNOPSIS | xargs 83 | test configure [OPTION]… 84 | -------------------------------------------------------------------------------- /lib/functoria/context_cache.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Astring 20 | open Action.Syntax 21 | 22 | let src = Logs.Src.create "functoria.cache" ~doc:"functoria library" 23 | 24 | module Log = (val Logs.src_log src : Logs.LOG) 25 | 26 | type t = string array 27 | 28 | let empty = [| "" |] 29 | let is_empty t = t = empty 30 | 31 | let write file argv = 32 | Log.info (fun m -> 33 | m "Preserving arguments in %a:@ %a" Fpath.pp file 34 | Fmt.Dump.(array string) 35 | argv); 36 | (* Only keep args *) 37 | let args = List.tl (Array.to_list argv) in 38 | let args = List.map String.Ascii.escape args in 39 | let args = String.concat ~sep:"\n" args ^ "\n" in 40 | Action.write_file file args 41 | 42 | let read file = 43 | Log.info (fun l -> l "reading cache %a" Fpath.pp file); 44 | let* is_file = Action.is_file file in 45 | if not is_file then Action.ok empty 46 | else 47 | let* args = Action.read_file file in 48 | let args = String.cuts ~sep:"\n" args in 49 | (* remove trailing '\n' *) 50 | let args = List.rev (List.tl (List.rev args)) in 51 | (* Add an empty command *) 52 | let args = "" :: args in 53 | let args = Array.of_list args in 54 | try 55 | let args = 56 | Array.map 57 | (fun x -> 58 | match String.Ascii.unescape x with 59 | | Some s -> s 60 | | None -> Fmt.failwith "%S: cannot parse" x) 61 | args 62 | in 63 | Action.ok args 64 | with Failure e -> Action.error e 65 | 66 | let peek t term = 67 | match Cmdliner.Cmd.eval_peek_opts ~argv:t term with 68 | | Some c, _ | _, Ok (`Ok c) -> Some c 69 | | _ -> None 70 | 71 | let merge t term = 72 | let cache = 73 | match peek t term with None -> Key.empty_context | Some c -> c 74 | in 75 | let f term = Key.merge_context ~default:cache term in 76 | Cmdliner.Term.(const f $ term) 77 | 78 | let peek_output t = Cli.peek_output t 79 | 80 | let file ~name args = 81 | let build_dir = Fpath.parent args.Cli.config_file in 82 | match args.Cli.context_file with 83 | | Some f -> f 84 | | None -> Fpath.(build_dir / name / "context") 85 | -------------------------------------------------------------------------------- /lib/functoria/lib.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Application builder. API for building libraries to link with [config.ml] *) 20 | 21 | (** {1 Builders} *) 22 | 23 | (** [S] is the signature that application builders have to provide. *) 24 | module type S = sig 25 | open DSL 26 | 27 | val prelude : Info.t -> string 28 | (** Prelude printed at the beginning of [main.ml]. 29 | 30 | It should put in scope: 31 | 32 | - a [run] function of type ['a t -> 'a] 33 | - a [return] function of type ['a -> 'a t] 34 | - a [>>=] operator of type ['a t -> ('a -> 'b t) -> 'b t] *) 35 | 36 | val packages : Package.t list 37 | (** The packages to load when compiling the configuration file. *) 38 | 39 | val name : string 40 | (** Name of the custom DSL. *) 41 | 42 | val version : string 43 | (** Version of the custom DSL. *) 44 | 45 | val create : job impl list -> job impl 46 | (** [create jobs] is the top-level job in the custom DSL which will execute 47 | the given list of [job]. *) 48 | 49 | val name_of_target : Info.t -> string 50 | (** [name_of_target i] is the name used to build the project with the build 51 | info [i]. For simple projects it can be [Info.name]. For more complex 52 | projects (like [mirage]), the name is suffixed by the value of the target 53 | key defined in [i]. *) 54 | 55 | val dune_project : Dune.stanza list 56 | val dune_workspace : (?build_dir:Fpath.t -> info -> Dune.t) option 57 | val context_name : Info.t -> string 58 | end 59 | 60 | module Make (P : S) : sig 61 | open DSL 62 | 63 | (** Configuration builder: stage 1 *) 64 | 65 | val register : 66 | ?packages:package list -> 67 | ?keys:abstract_key list -> 68 | ?init:job impl list -> 69 | ?src:[ `Auto | `None | `Some of string ] -> 70 | string -> 71 | job impl list -> 72 | unit 73 | (** [register name jobs] registers the application named by [name] which will 74 | execute the given [jobs]. Same optional arguments as {!module-DSL.main}. 75 | 76 | [init] is the list of job to execute before anything else (such as 77 | command-line argument parsing, log reporter setup, etc.). The jobs are 78 | always executed in the sequence specified by the caller. *) 79 | end 80 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 |
2 | 3 | MirageOS logo 4 | 5 |
6 | Build Unikernels in OCaml 7 |
8 | 9 |
10 |
11 | 12 | [![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https%3A%2F%2Fci.ocamllabs.io%2Fbadge%2Fmirage%2Fmirage%2Fmain&logo=ocaml&style=flat-square)](https://ci.ocamllabs.io/github/mirage/mirage) 13 | [![docs](https://img.shields.io/badge/doc-online-blue.svg)](https://mirage.github.io/mirage/) 14 | 15 |
16 | 17 |
18 | 19 |
20 | 21 | MirageOS is a library operating system that constructs secure, 22 | performant and resource-efficient unikernels. 23 | 24 |
25 | 26 | ## About 27 | 28 | MirageOS is a library operating system that constructs unikernels for 29 | secure, high-performance network applications across various cloud 30 | computing and mobile platforms. Developers can write code on a 31 | traditional OS such as Linux or macOS. They can then compile their 32 | code into a fully-standalone, specialised unikernel that runs under 33 | the Xen or KVM hypervisors and lightweight hypervisors like FreeBSD's 34 | BHyve, OpenBSD's VMM. These unikernels can deploy on public clouds, 35 | like Amazon's Elastic Compute Cloud and Google Compute Engine, or 36 | private deployments. 37 | 38 | The most up-to-date documentation can be found at the 39 | [homepage](https://mirage.io). The site is [a self-hosted 40 | unikernel](https://github.com/mirage/mirage-www). Simpler [skeleton 41 | applications](https://github.com/mirage/mirage-skeleton) are also 42 | available online. MirageOS unikernels repositories are also available 43 | [here](https://github.com/roburio/unikernels) or 44 | [there](https://github.com/tarides/unikernels). 45 | 46 | ### This repository 47 | 48 | This repository contains the `mirage` command-line tool to create and 49 | deploy applications with MirageOS. This tool wraps the specialised 50 | configuration and build steps required to build MirageOS on all the 51 | supported targets. 52 | 53 | **Local install** 54 | 55 | You will need the following: 56 | 57 | * a working [OCaml](https://ocaml.org) compiler (4.08.0 or higher). 58 | * the [Opam](https://opam.ocaml.org) source package manager (2.1.0 or higher). 59 | * an x86\_64 or armel Linux host to compile Xen kernels, or FreeBSD, OpenBSD or 60 | MacOS X for the solo5 and userlevel versions. 61 | 62 | Then run: 63 | 64 | ``` 65 | $ opam install mirage 66 | $ mirage --version 67 | ``` 68 | 69 | This should display at least version `4.0.0`. 70 | 71 | ### Using `mirage` 72 | 73 | There are multiple stages to using `mirage`: 74 | 75 | * write `config.ml` to describe the components of your applications; 76 | * call `mirage configure` to generate the necessary code and metadata; 77 | * optionally call `make depends` to install external dependencies and 78 | download Opam packages in the current [dune](https://dune.build/) workspace. 79 | * call `dune build` to build a unikernel. 80 | 81 | You can find documentation, walkthroughs and tutorials over on the 82 | [MirageOS website](https://mirage.io). 83 | The [install instructions](https://mirage.io/wiki/install) 84 | are a good place to begin! 85 | -------------------------------------------------------------------------------- /test/functoria/test_graph.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | 3 | let x = Impl.v "Foo.Bar" Functoria.job 4 | let y = Impl.v "X.Y" Functoria.(job @-> job) ~extra_deps:[ Impl.abstract x ] 5 | let z = Impl.v "Bar" job ~extra_deps:[ Impl.abstract y ] 6 | 7 | let z, y, x = 8 | let g = Impl.abstract z in 9 | let g = Impl.eval ~context:Key.empty_context g in 10 | match Device.Graph.fold List.cons g [] with 11 | | [ x; y; z ] -> (x, y, z) 12 | | _ -> assert false 13 | 14 | let var_name x = Device.Graph.var_name x 15 | let impl_name x = Device.Graph.impl_name x 16 | let ident s i = Fmt.str "%s__%d" s i 17 | 18 | let test_var_name () = 19 | Alcotest.(check string) "x" (ident "foo_bar" 1) (var_name x); 20 | Alcotest.(check string) "y" (ident "x_y" 2) (var_name y); 21 | Alcotest.(check string) "z" (ident "bar" 3) (var_name z) 22 | 23 | let test_impl_name () = 24 | Alcotest.(check string) "x" "Foo.Bar" (impl_name x); 25 | Alcotest.(check string) "y" (ident "X_y" 2) (impl_name y); 26 | Alcotest.(check string) "z" "Bar" (impl_name z) 27 | 28 | let d1 = Device.v ~packages:[ package "a" ] "Foo.Bar" job 29 | let d2 = Device.v ~packages:[ package "b" ] "Foo.Bar" job 30 | let i1 = of_device d1 31 | let i2 = of_device d2 32 | let if1 = if_impl (Key.pure true) i1 i2 33 | let if2 = if_impl (Key.pure true) i2 i1 34 | 35 | let normalise_lines str = 36 | let open Astring in 37 | let lines = String.cuts ~empty:true ~sep:"\n" str in 38 | let lines = 39 | List.map 40 | (fun line -> if String.for_all Char.Ascii.is_blank line then "" else line) 41 | lines 42 | in 43 | String.concat ~sep:"\n" lines 44 | 45 | let graph_str g = normalise_lines (Fmt.to_to_string Impl.pp_dot g) 46 | 47 | let digraph i = 48 | let j = i + 1 and k = i + 2 in 49 | Fmt.str 50 | {|digraph G { 51 | ordering=out; 52 | %d [label="foo_bar__%d\nFoo.Bar\n", shape="box"]; 53 | %d [label="foo_bar__%d\nFoo.Bar\n", shape="box"]; 54 | %d [label="If\n"]; 55 | 56 | %d -> %d [style="dotted", headport="n"]; 57 | %d -> %d [style="dotted", headport="n"]; 58 | %d -> %d [style="bold", style="dotted", headport="n"]; 59 | }|} 60 | i i j j k k i k j k i 61 | 62 | let test_graph () = 63 | let t1 = Impl.abstract if1 in 64 | Alcotest.(check string) "t1.dot" (digraph 1) (graph_str t1); 65 | let t2 = Impl.abstract if2 in 66 | Alcotest.(check string) "t2.dot" (digraph 1) (graph_str t2); 67 | let module M = struct 68 | type t = (string * string list) list 69 | 70 | let empty = [] 71 | let union = List.append 72 | end in 73 | let packages t = 74 | let ctx = Key.empty_context in 75 | Impl.collect 76 | (module M) 77 | (function 78 | | If _ | App -> [] 79 | | Dev d -> 80 | let pkgs = Key.(eval ctx (Device.packages d)) in 81 | List.map (fun pkg -> (Package.name pkg, Package.libraries pkg)) pkgs) 82 | (Impl.simplify ~full:true ~context:ctx t) 83 | in 84 | let label = Alcotest.(list (pair string (list string))) in 85 | Alcotest.(check label) "t1" [ ("a", [ "a" ]) ] (packages t1); 86 | Alcotest.(check label) "t2" [ ("b", [ "b" ]) ] (packages t2) 87 | 88 | let suite = 89 | [ 90 | ("var_name", `Quick, test_var_name); 91 | ("impl_name", `Quick, test_impl_name); 92 | ("test_graph", `Quick, test_graph); 93 | ] 94 | -------------------------------------------------------------------------------- /lib_runtime/functoria/functoria_runtime.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Gabriel Radanne 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Arg = struct 18 | type 'a kind = 19 | | Opt : 'a * 'a Cmdliner.Arg.conv -> 'a kind 20 | | Opt_all : 'a list * 'a Cmdliner.Arg.conv -> 'a list kind 21 | | Flag : bool kind 22 | | Required : 'a Cmdliner.Arg.conv -> 'a kind 23 | 24 | type 'a t = { info : Cmdliner.Arg.info; kind : 'a kind } 25 | 26 | let flag info = { info; kind = Flag } 27 | let opt conv default info = { info; kind = Opt (default, conv) } 28 | let opt_all conv default info = { info; kind = Opt_all (default, conv) } 29 | let required conv info = { info; kind = Required conv } 30 | 31 | let key ?default c i = 32 | match default with None -> required c i | Some d -> opt c d i 33 | 34 | let default (type a) (t : a t) = 35 | match t.kind with 36 | | Opt (d, _) -> Some d 37 | | Opt_all (d, _) -> Some d 38 | | Flag -> Some false 39 | | Required _ -> None 40 | 41 | let kind t = t.kind 42 | let info t = t.info 43 | end 44 | 45 | module Key = struct 46 | type 'a t = { arg : 'a Arg.t; mutable value : 'a option } 47 | 48 | let create arg = { arg; value = None } 49 | 50 | let get t = 51 | match t.value with 52 | | None -> 53 | invalid_arg 54 | "Key.get: Called too early. Please delay this call after cmdliner's \ 55 | evaluation." 56 | | Some v -> v 57 | 58 | let default t = Arg.default t.arg 59 | 60 | let term (type a) (t : a t) = 61 | let set w = t.value <- Some w in 62 | let doc = Arg.info t.arg in 63 | let term arg = Cmdliner.Term.(const set $ arg) in 64 | match Arg.kind t.arg with 65 | | Arg.Flag -> term @@ Cmdliner.Arg.(value & flag doc) 66 | | Arg.Opt (default, desc) -> 67 | term @@ Cmdliner.Arg.(value & opt desc default doc) 68 | | Arg.Opt_all (default, desc) -> 69 | term @@ Cmdliner.Arg.(value & opt_all desc default doc) 70 | | Arg.Required desc -> 71 | term @@ Cmdliner.Arg.(required & opt (some desc) None doc) 72 | end 73 | 74 | let initialized = ref false 75 | let help_version = 63 76 | let argument_error = 64 77 | 78 | let with_argv keys s argv = 79 | let open Cmdliner in 80 | if !initialized then () 81 | else 82 | let gather k rest = Term.(const (fun () () -> ()) $ k $ rest) in 83 | let t = List.fold_right gather keys (Term.const ()) in 84 | match Cmd.(eval_value ~argv (Cmd.v (info s) t)) with 85 | | Ok (`Ok _) -> 86 | initialized := true; 87 | () 88 | | Error _ -> exit argument_error 89 | | Ok `Help | Ok `Version -> exit help_version 90 | 91 | type info = { name : string; libraries : (string * string) list } 92 | -------------------------------------------------------------------------------- /lib/functoria/install.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type t = { bin : (Fpath.t * Fpath.t) list; etc : Fpath.t list } 20 | 21 | let v ?(bin = []) ?(etc = []) () = { bin; etc } 22 | let empty = v () 23 | 24 | let dump ppf t = 25 | let bin ppf t = Fmt.Dump.(list (pair Fpath.pp Fpath.pp)) ppf t.bin in 26 | let etc ppf t = Fmt.Dump.(list Fpath.pp) ppf t.etc in 27 | Fmt.Dump.record [ bin; etc ] ppf t 28 | 29 | let pp ppf t = 30 | let pp_bin ppf (src, dst) = 31 | Fmt.pf ppf "\n \"%a\" {\"%a\"}" Fpath.pp src Fpath.pp dst 32 | in 33 | let pp_etc ppf file = 34 | Fmt.pf ppf "\n \"%a\" {\"%s\"}" Fpath.pp file Fpath.(basename file) 35 | in 36 | let bins = List.map (Fmt.to_to_string pp_bin) t.bin in 37 | let etcs = List.map (Fmt.to_to_string pp_etc) t.etc in 38 | Fmt.pf ppf "bin: [%s%s]\n" (String.concat "" bins) 39 | (match bins with [] -> "" | _ -> "\n"); 40 | Fmt.pf ppf "etc: [%s%s]" (String.concat "" etcs) 41 | (match etcs with [] -> "" | _ -> "\n") 42 | 43 | let pp_opam ?subdir () ppf t = 44 | let pp_bin ppf (src, dst) = 45 | Fmt.pf ppf {|"cp" "%adist/%a" "%%{bin}%%/%a"|} 46 | Fmt.(option ~none:(any "") Fpath.pp) 47 | subdir Fpath.pp src Fpath.pp dst 48 | in 49 | let pp_etc ppf etc = 50 | Fmt.pf ppf {|"cp" "%adist/%a" "%%{etc}%%"|} 51 | Fmt.(option ~none:(any "") Fpath.pp) 52 | subdir Fpath.pp etc 53 | in 54 | Fmt.pf ppf "\n%a\n" 55 | (Fmt.list ~sep:(Fmt.any "\n") (fun ppf -> Fmt.pf ppf " [ %a ]" pp_bin)) 56 | t.bin; 57 | match t.etc with 58 | | [] -> () 59 | | _ -> 60 | Fmt.pf ppf "%a\n" 61 | (Fmt.list ~sep:(Fmt.any "\n") (fun ppf -> Fmt.pf ppf " [ %a ]" pp_etc)) 62 | t.etc 63 | 64 | let promote_artifact ~context_name ~src ~dst = 65 | Dune.stanzaf 66 | {| 67 | (rule 68 | (mode (promote (until-clean))) 69 | (target %a) 70 | (enabled_if (= %%{context_name} "%s")) 71 | (action 72 | (copy %a %%{target})) 73 | ) 74 | |} 75 | Fpath.pp dst context_name Fpath.pp 76 | Fpath.(v ".." // src) 77 | 78 | let dune ~context_name_for_bin ~context_name_for_etc t = 79 | let bin_rules = 80 | List.map 81 | (fun (src, dst) -> 82 | promote_artifact ~context_name:context_name_for_bin ~src ~dst) 83 | t.bin 84 | in 85 | let etc_rules = 86 | List.map 87 | (fun etc -> 88 | promote_artifact ~context_name:context_name_for_etc ~src:etc ~dst:etc) 89 | t.etc 90 | in 91 | Dune.v (bin_rules @ etc_rules) 92 | 93 | let union_etc x y = Fpath.Set.(elements (union (of_list x) (of_list y))) 94 | let union_bin x y = x @ y 95 | let union x y = { bin = union_bin x.bin y.bin; etc = union_etc x.etc y.etc } 96 | -------------------------------------------------------------------------------- /lib/functoria/filegen.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Astring 20 | open Action.Syntax 21 | 22 | module type PROJECT = sig 23 | val name : string 24 | val version : string 25 | end 26 | 27 | module Make (P : PROJECT) = struct 28 | let lang path = 29 | let base, ext = Fpath.split_ext path in 30 | let base = Fpath.basename base in 31 | match (base, ext) with 32 | | _, (".ml" | ".mli") -> Some `OCaml 33 | | _, (".opam" | ".install") -> Some `Opam 34 | | "Makefile", _ -> Some `Make 35 | | ("dune" | "dune-project" | "dune-workspace"), _ -> Some `Sexp 36 | | _ -> None 37 | 38 | let headers lang = 39 | let line = Fmt.str "Generated by %s.%s" P.name P.version in 40 | match lang with 41 | | `Sexp -> Fmt.str ";; %s" line 42 | | `Opam | `Make -> Fmt.str "# %s" line 43 | | `OCaml -> Fmt.str "(* %s *)" line 44 | 45 | let short_headers lang = 46 | match lang with 47 | | `Sexp -> Fmt.str ";; Generated by" 48 | | `Opam | `Make -> "# Generated by" 49 | | `OCaml -> "(* Generated by" 50 | 51 | let has_headers file contents = 52 | match Fpath.basename file with 53 | | "dune-project" | "dune-workspace" -> ( 54 | let lines = String.cuts ~sep:"\n" ~empty:true (String.trim contents) in 55 | match List.rev lines with 56 | | x :: _ -> String.is_infix ~affix:(short_headers `Sexp) x 57 | | _ -> false) 58 | | _ -> ( 59 | match lang file with 60 | | None -> false 61 | | Some lang -> 62 | let affix = short_headers lang in 63 | String.is_infix ~affix contents) 64 | 65 | let can_overwrite file = 66 | let* is_file = Action.is_file file in 67 | if is_file then 68 | let+ content = Action.read_file file in 69 | has_headers file content 70 | else Action.ok true 71 | 72 | let rm file = 73 | let* can_overwrite = can_overwrite file in 74 | if not can_overwrite then Action.ok () else Action.rm file 75 | 76 | let with_headers file contents = 77 | if has_headers file contents then contents 78 | else 79 | match Fpath.basename file with 80 | | "dune-project" | "dune-workspace" | "dune-workspace.config" -> 81 | Fmt.str "%s\n%s\n" contents (headers `Sexp) 82 | | _ -> ( 83 | match lang file with 84 | | None -> Fmt.invalid_arg "%a: invalide lang" Fpath.pp file 85 | | Some lang -> Fmt.str "%s\n\n%s" (headers lang) contents) 86 | 87 | let write file contents = 88 | let* can_overwrite = can_overwrite file in 89 | if not can_overwrite then Action.ok () 90 | else Action.write_file file (with_headers file contents) 91 | end 92 | -------------------------------------------------------------------------------- /lib/functoria/package.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Representation of opam packages. *) 20 | 21 | type scope = [ `Switch | `Monorepo ] 22 | (** The scope of package installation: 23 | 24 | - Switch: installed with opam. 25 | - Monorepo: locally fetched along unikernel sources. *) 26 | 27 | type t 28 | (** The type for opam packages. *) 29 | 30 | val v : 31 | ?scope:scope -> 32 | ?build:bool -> 33 | ?sublibs:string list -> 34 | ?libs:string list -> 35 | ?min:string -> 36 | ?max:string -> 37 | ?pin:string -> 38 | ?pin_version:string -> 39 | string -> 40 | t 41 | (** [v ~scope ~build ~sublibs ~libs ~min ~max ~pin opam] is a [package]. [Build] 42 | indicates a build-time dependency only, defaults to [false]. The library 43 | name is by default the same as [opam], you can specify [~sublibs] to add 44 | additional sublibraries (e.g. [~sublibs:\["mirage"\] "foo"] will result in 45 | the library names [\["foo"; "foo.mirage"\]]. In case the library name is 46 | disjoint (or empty), use [~libs]. Specifying both [~libs] and [~sublibs] 47 | leads to an invalid argument. Version constraints are given as [min] 48 | (inclusive) and [max] (exclusive). If [pin] is provided, a 49 | {{:https://opam.ocaml.org/doc/Manual.html#opamfield-pin-depends} 50 | pin-depends} is generated, [pin_version] is ["dev"] by default. [~scope] 51 | specifies the installation location of the package. *) 52 | 53 | val with_scope : scope:scope -> t -> t 54 | (** [with_scope t] returns t with chosen installation location.*) 55 | 56 | val name : t -> string 57 | (** [name t] is [t]'s opam name. *) 58 | 59 | val key : t -> string 60 | (** [key t] is [t]'s key (concatenation of name and installation scope). *) 61 | 62 | val scope : t -> scope 63 | (** [scope t] is [t]'s installation scope. *) 64 | 65 | val pin : t -> (string * string) option 66 | (** [pin t] is [Some (name_version, r)] iff [t] is pinned to the repository [r]. *) 67 | 68 | val build_dependency : t -> bool 69 | (** [build_dependency t] is [true] iff [t] is a build-time dependency. *) 70 | 71 | val libraries : t -> string list 72 | (** [libraries t] is the set of libraries (and sub-libraries) used in the 73 | package [t]. For most packages, it will only contain one library whose name 74 | is [name t]. *) 75 | 76 | val max_versions : t -> string list 77 | (** [max_versions] is the set of maximum versions of [t] which are required. *) 78 | 79 | val min_versions : t -> string list 80 | (** [min_versions] is the set minimum versions of [t] which are required. *) 81 | 82 | val merge : t -> t -> t option 83 | (** [merge x y] is merges the information of [x] and [y]. The result is [None] 84 | if [name x != name y]. *) 85 | 86 | val pp : ?surround:string -> t Fmt.t 87 | (** [pp] is the pretty-printer for packages. *) 88 | -------------------------------------------------------------------------------- /lib_runtime/mirage/mirage_runtime.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 David Sheets 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | type log_threshold = [ `All | `Src of string ] * Logs.level option 18 | 19 | let set_level ~default l = 20 | let srcs = Logs.Src.list () in 21 | let default = 22 | try snd @@ List.find (function `All, _ -> true | _ -> false) l 23 | with Not_found -> default 24 | in 25 | Logs.set_level default; 26 | List.iter 27 | (function 28 | | `All, _ -> () 29 | | `Src src, level -> ( 30 | try 31 | let s = List.find (fun s -> Logs.Src.name s = src) srcs in 32 | Logs.Src.set_level s level 33 | with Not_found -> 34 | Fmt.(pf stdout) 35 | "%a %s is not a valid log source.\n%!" 36 | Fmt.(styled `Yellow string) 37 | "Warning:" src)) 38 | l 39 | 40 | module Arg = struct 41 | include Functoria_runtime.Arg 42 | 43 | let make of_string to_string : _ Cmdliner.Arg.conv = 44 | Cmdliner.Arg.conv (of_string, Fmt.of_to_string to_string) 45 | 46 | module type S = sig 47 | type t 48 | 49 | val of_string : string -> (t, [ `Msg of string ]) result 50 | val to_string : t -> string 51 | end 52 | 53 | let of_module (type t) (module M : S with type t = t) = 54 | make M.of_string M.to_string 55 | 56 | let ip_address = of_module (module Ipaddr) 57 | let ipv4_address = of_module (module Ipaddr.V4) 58 | let ipv4 = of_module (module Ipaddr.V4.Prefix) 59 | let ipv6_address = of_module (module Ipaddr.V6) 60 | let ipv6 = of_module (module Ipaddr.V6.Prefix) 61 | 62 | let log_threshold = 63 | let parser str = 64 | let level src s = 65 | Result.bind (Logs.level_of_string s) (fun l -> Ok (src, l)) 66 | in 67 | match String.split_on_char ':' str with 68 | | [ _ ] -> level `All str 69 | | [ "*"; lvl ] -> level `All lvl 70 | | [ src; lvl ] -> level (`Src src) lvl 71 | | _ -> Error (`Msg ("Can't parse log threshold: " ^ str)) 72 | in 73 | let serialize ppf = function 74 | | `All, l -> Fmt.string ppf (Logs.level_to_string l) 75 | | `Src s, l -> Fmt.pf ppf "%s:%s" s (Logs.level_to_string l) 76 | in 77 | Cmdliner.Arg.conv (parser, serialize) 78 | 79 | let allocation_policy = 80 | Cmdliner.Arg.enum 81 | [ 82 | ("next-fit", `Next_fit); 83 | ("first-fit", `First_fit); 84 | ("best-fit", `Best_fit); 85 | ] 86 | end 87 | 88 | include ( 89 | Functoria_runtime : module type of Functoria_runtime with module Arg := Arg) 90 | 91 | let exit_hooks = ref [] 92 | let enter_iter_hooks = ref [] 93 | let leave_iter_hooks = ref [] 94 | let run t = List.iter (fun f -> f ()) !t 95 | let add f t = t := f :: !t 96 | 97 | let run_exit_hooks () = 98 | Lwt_list.iter_s 99 | (fun hook -> Lwt.catch (fun () -> hook ()) (fun _ -> Lwt.return_unit)) 100 | !exit_hooks 101 | 102 | let run_enter_iter_hooks () = run enter_iter_hooks 103 | let run_leave_iter_hooks () = run leave_iter_hooks 104 | let at_exit f = add f exit_hooks 105 | let at_leave_iter f = add f leave_iter_hooks 106 | let at_enter_iter f = add f enter_iter_hooks 107 | -------------------------------------------------------------------------------- /lib_runtime/functoria/functoria_runtime.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Functoria runtime. *) 20 | 21 | (** [Arg] defines command-line arguments which can be set at runtime. This 22 | module is the runtime companion of [Functoria.Key]. It exposes a subset of 23 | {{:http://erratique.ch/software/cmdliner/doc/Cmdliner/Arg/index.html} 24 | Cmdliner.Arg}. *) 25 | module Arg : sig 26 | (** {1 Runtime command-line arguments} *) 27 | 28 | type 'a t 29 | (** The type for runtime command-line arguments. Similar to 30 | [Functoria.Key.Arg.t] but only available at runtime. *) 31 | 32 | val opt : 'a Cmdliner.Arg.conv -> 'a -> Cmdliner.Arg.info -> 'a t 33 | (** [opt] is the runtime companion of [Functoria.Ky.Arg.opt]. *) 34 | 35 | val opt_all : 36 | 'a Cmdliner.Arg.conv -> 'a list -> Cmdliner.Arg.info -> 'a list t 37 | (** [opt_all] is the runtime companion of [Functoria.Key.Arg.opt_all]. *) 38 | 39 | val required : 'a Cmdliner.Arg.conv -> Cmdliner.Arg.info -> 'a t 40 | (** [required] is the runtime companion of [Functoria.Key.Arg.required]. *) 41 | 42 | val key : ?default:'a -> 'a Cmdliner.Arg.conv -> Cmdliner.Arg.info -> 'a t 43 | (** [key] is either {!opt} or {!required}, depending if [~default] is 44 | provided. *) 45 | 46 | val flag : Cmdliner.Arg.info -> bool t 47 | (** [flag] is the runtime companion of [Functoria.Key.Arg.flag]. *) 48 | end 49 | 50 | (** [Key] defines values that can be set by runtime command-line arguments. This 51 | module is the runtime companion of {!Key}. *) 52 | module Key : sig 53 | (** {1 Runtime keys} *) 54 | 55 | type 'a t 56 | (** The type for runtime keys containing a value of type ['a]. *) 57 | 58 | val create : 'a Arg.t -> 'a t 59 | (** [create conv] create a new runtime key. *) 60 | 61 | val get : 'a t -> 'a 62 | (** [get k] is the value of the key [k]. Use the default value if no 63 | command-line argument is provided. 64 | 65 | @raise Invalid_argument if called before cmdliner's evaluation. *) 66 | 67 | val default : 'a t -> 'a option 68 | (** [default k] is the default value of [k], if one is available. This 69 | function can be called before cmdliner's evaluation. *) 70 | 71 | val term : 'a t -> unit Cmdliner.Term.t 72 | (** [term k] is the [Cmdliner] term whose evaluation sets [k]s' value to the 73 | parsed command-line argument. *) 74 | end 75 | 76 | val argument_error : int 77 | (** [argument_error] is the exit code used for argument parsing errors: 64. *) 78 | 79 | val with_argv : unit Cmdliner.Term.t list -> string -> string array -> unit 80 | (** [with_argv keys name argv] evaluates the [keys] {{!Key.term} terms} on the 81 | command-line [argv]. [name] is the executable name. On evaluation error the 82 | application calls [exit(3)] with status [64]. If [`Help] or [`Version] were 83 | evaluated, [exit(3)] is called with status [63]. *) 84 | 85 | type info = { 86 | name : string; 87 | libraries : (string * string) list; (** the result of [dune-build-info] *) 88 | } 89 | (** The type for build information available at runtime. *) 90 | -------------------------------------------------------------------------------- /lib/mirage/impl/mirage_impl_git.ml: -------------------------------------------------------------------------------- 1 | open Functoria 2 | open Mirage_impl_time 3 | open Mirage_impl_mclock 4 | open Mirage_impl_pclock 5 | open Mirage_impl_stack 6 | open Mirage_impl_tcp 7 | open Mirage_impl_dns 8 | open Mirage_impl_happy_eyeballs 9 | open Mirage_impl_mimic 10 | 11 | type git_client = Git_client 12 | 13 | let git_client = Type.v Git_client 14 | 15 | let git_merge_clients = 16 | let packages = [ package "mimic" ] in 17 | let connect _ _modname = function 18 | | [ a; b ] -> Fmt.str "Lwt.return (Mimic.merge %s %s)" a b 19 | | [ x ] -> Fmt.str "%s.ctx" x 20 | | _ -> Fmt.str "Lwt.return Mimic.empty" 21 | in 22 | impl ~packages ~connect "Mimic.Merge" 23 | (git_client @-> git_client @-> git_client) 24 | 25 | let git_happy_eyeballs = 26 | let packages = [ package "mimic-happy-eyeballs" ~min:"0.0.5" ] in 27 | let connect _ modname = function 28 | | [ _stackv4v6; _dns_client; happy_eyeballs ] -> 29 | Fmt.str {ocaml|%s.connect %s|ocaml} modname happy_eyeballs 30 | | _ -> assert false 31 | in 32 | impl ~packages ~connect "Mimic_happy_eyeballs.Make" 33 | (stackv4v6 @-> dns_client @-> happy_eyeballs @-> mimic) 34 | 35 | let git_tcp = 36 | let packages = 37 | [ package "git-mirage" ~sublibs:[ "tcp" ] ~min:"3.10.0" ~max:"3.11.0" ] 38 | in 39 | let connect _ modname = function 40 | | [ _tcpv4v6; ctx ] -> Fmt.str {ocaml|%s.connect %s|ocaml} modname ctx 41 | | _ -> assert false 42 | in 43 | impl ~packages ~connect "Git_mirage_tcp.Make" 44 | (tcpv4v6 @-> mimic @-> git_client) 45 | 46 | let git_ssh ?authenticator key = 47 | let packages = 48 | [ package "git-mirage" ~sublibs:[ "ssh" ] ~min:"3.10.0" ~max:"3.11.0" ] 49 | in 50 | let connect _ modname = function 51 | | [ _mclock; _tcpv4v6; _time; ctx ] -> ( 52 | match authenticator with 53 | | None -> 54 | Fmt.str 55 | {ocaml|%s.connect %s >>= %s.with_optionnal_key ~key:%a|ocaml} 56 | modname ctx modname Key.serialize_call (Key.v key) 57 | | Some authenticator -> 58 | Fmt.str 59 | {ocaml|%s.connect %s >>= %s.with_optionnal_key ?authenticator:%a ~key:%a|ocaml} 60 | modname ctx modname Key.serialize_call (Key.v authenticator) 61 | Key.serialize_call (Key.v key)) 62 | | _ -> assert false 63 | in 64 | let keys = 65 | match authenticator with 66 | | Some authenticator -> [ Key.v key; Key.v authenticator ] 67 | | None -> [ Key.v key ] 68 | in 69 | impl ~packages ~connect ~keys "Git_mirage_ssh.Make" 70 | (mclock @-> tcpv4v6 @-> time @-> mimic @-> git_client) 71 | 72 | let git_http ?authenticator headers = 73 | let packages = 74 | [ package "git-mirage" ~sublibs:[ "http" ] ~min:"3.10.0" ~max:"3.11.0" ] 75 | in 76 | let keys = 77 | let keys = [] in 78 | let keys = 79 | match headers with Some headers -> Key.v headers :: keys | None -> keys 80 | in 81 | let keys = 82 | match authenticator with 83 | | Some authenticator -> Key.v authenticator :: keys 84 | | None -> [] 85 | in 86 | keys 87 | in 88 | let connect _ modname = function 89 | | [ _pclock; _tcpv4v6; ctx ] -> 90 | let serialize_headers ppf = function 91 | | None -> () 92 | | Some headers -> 93 | Fmt.pf ppf " ?headers:%a" Key.serialize_call (Key.v headers) 94 | in 95 | let serialize_authenticator ppf = function 96 | | None -> () 97 | | Some authenticator -> 98 | Fmt.pf ppf " ?authenticator:%a" Key.serialize_call 99 | (Key.v authenticator) 100 | in 101 | Fmt.str 102 | {ocaml|%s.connect %s >>= fun ctx -> %s.with_optional_tls_config_and_headers%a%a ctx|ocaml} 103 | modname ctx modname serialize_authenticator authenticator 104 | serialize_headers headers 105 | | _ -> assert false 106 | in 107 | impl ~packages ~connect ~keys "Git_mirage_http.Make" 108 | (pclock @-> tcpv4v6 @-> mimic @-> git_client) 109 | -------------------------------------------------------------------------------- /lib/functoria/dune.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2020 Thomas Gazagnaire 3 | * Copyright (c) 2013-2020 Anil Madhavapeddy 4 | * Copyright (c) 2015-2020 Gabriel Radanne 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Astring 20 | 21 | type stanza = string option 22 | type t = string list 23 | 24 | let stanza v = Some (String.trim v) 25 | let stanzaf fmt = Fmt.kstr stanza fmt 26 | 27 | let v x : t = 28 | List.fold_left 29 | (fun acc -> function None -> acc | Some f -> f :: acc) 30 | [] (List.rev x) 31 | 32 | let pp_list pp = Fmt.(list ~sep:(any "\n\n") pp) 33 | let pp ppf (t : t) = Fmt.pf ppf "%a" (pp_list Fmt.string) t 34 | let to_string t = Fmt.to_to_string pp t ^ "\n" 35 | 36 | let headers ~name ~version = 37 | let module M = Filegen.Make (struct 38 | let name = name 39 | let version = version 40 | end) in 41 | M.headers `Sexp 42 | 43 | (* emulate the dune compact form for lists *) 44 | let compact_list ?(indent = 2) field ppf l = 45 | let all = Buffer.create 1024 in 46 | let line = Buffer.create 70 in 47 | let sep = "\n" ^ String.v ~len:indent (fun _ -> ' ') in 48 | let first_char = ref true in 49 | let first_line = ref true in 50 | let flush () = 51 | Buffer.add_buffer all line; 52 | Buffer.clear line; 53 | Buffer.add_string line sep; 54 | first_line := false 55 | in 56 | List.iter 57 | (fun w -> 58 | let max = if !first_line then 75 - indent - String.length field else 75 in 59 | let wn = String.length w in 60 | if wn >= 40 || Buffer.length line + wn >= max then flush (); 61 | if not !first_char then Buffer.add_char line ' '; 62 | first_char := false; 63 | Buffer.add_string line w) 64 | l; 65 | flush (); 66 | Fmt.pf ppf "%s" (Buffer.contents all) 67 | 68 | let config_rule ~config_ml_file ~packages ~name ~version = 69 | let headers = headers ~name ~version in 70 | let pkgs = 71 | match packages with 72 | | [] -> "" 73 | | pkgs -> 74 | let pkgs = 75 | List.fold_left 76 | (fun acc pkg -> 77 | let pkgs = String.Set.of_list (Package.libraries pkg) in 78 | String.Set.union pkgs acc) 79 | String.Set.empty pkgs 80 | |> String.Set.elements 81 | in 82 | String.concat ~sep:" " pkgs 83 | in 84 | let rename_config_file = 85 | let config_ml_file = Fpath.base config_ml_file in 86 | let ext = Fpath.get_ext config_ml_file in 87 | let name = Fpath.rem_ext config_ml_file |> Fpath.to_string in 88 | if name = "config" then "" 89 | else 90 | Fmt.str "(rule (copy %s config%s))" (Fpath.to_string config_ml_file) ext 91 | in 92 | let contents = 93 | Fmt.str 94 | {|%s 95 | 96 | %s 97 | (executable 98 | (name config) 99 | (modules config) 100 | (libraries %s)) 101 | |} 102 | headers rename_config_file pkgs 103 | in 104 | v [ stanza contents ] 105 | 106 | let base ~packages ~name ~version ~config_ml_file = 107 | let dune_base = config_rule ~config_ml_file ~packages ~name ~version in 108 | let disable_duniverse = "(data_only_dirs duniverse)" in 109 | disable_duniverse :: dune_base 110 | 111 | let base_project = [ stanza "(lang dune 2.7)" ] 112 | let base_workspace = v [ stanza "(lang dune 2.0)\n(context default)" ] 113 | --------------------------------------------------------------------------------