Capnp part 1

.gitignore

···
 *.sjson
 *.json
 *.shl
+
+docs/trees
+docs/output

src/common/admin.ml

···
+open Capnp_rpc
+
+let v sr ~add_user ~remove_user =
+  let module X = Raw.Service.Admin in
+  Capnp_rpc.Persistence.with_sturdy_ref sr X.local
+  @@ object
+       inherit X.service
+
+       method add_user_impl params release_param_caps =
+         let open X.AddUser in
+         let id = Params.user_get params in
+         release_param_caps ();
+         let cap = add_user id in
+         let response, results = Service.Response.create Results.init_pointer in
+         Results.cap_set results (Some cap);
+         Capability.dec_ref cap;
+         Service.return response
+
+       method remove_user_impl params release_param_caps =
+         let open X.RemoveUser in
+         let id = Params.user_get params in
+         release_param_caps ();
+         remove_user id;
+         Service.return @@ Service.Response.create_empty ()
+     end
+
+module X = Raw.Client.Admin
+
+type t = X.t Capability.t
+
+let add_user t user =
+  let open X.AddUser in
+  let request, params = Capability.Request.create Params.init_pointer in
+  Params.user_set params user;
+  Capability.call_for_caps t method_id request Results.cap_get_pipelined
+
+let remove_user t user =
+  let open X.RemoveUser in
+  let request, params = Capability.Request.create Params.init_pointer in
+  Params.user_set params user;
+  let _ : _ StructStorage.reader_t =
+    Capability.call_for_value_exn t method_id request
+  in
+  ()

src/common/config.ml

···
+type t = { shell : string; default_image : string } [@@deriving yojson]

src/common/dune

···
+(rule
+ (targets schema.ml schema.mli)
+ (deps schema.capnp)
+ (action
+  (run capnpc -o %{bin:capnpc-ocaml} %{deps})))
+
+(library
+ (name shelter_common)
+ (preprocess
+  (pps ppx_deriving_yojson))
+ (flags
+  (:standard -w -53-55))
+ (libraries capnp-rpc-net))

src/common/raw.ml

···
+include Schema.MakeRPC (Capnp_rpc)

src/common/schema.capnp

···
+@0x91b3108e7ebb3830;
+interface Session {
+  stdin  @0 (input :Text) -> ();
+  stdout @1 () -> (output :Text);
+  stderr @2 () -> (output :Text);
+}
+
+interface User {
+  connect @0 (config :Text) -> (cap :Session);
+  # Connect to the daemon and get a live session.
+}
+
+
+interface Admin {
+  addUser @0 (user :Text) -> (cap :User);
+  # Add a new user, returning a capability to act as a full
+  # Shelter user.
+
+  removeUser @1 (user :Text) -> ();
+  # Remove a user, this will also cancel existing connections
+  # this user may have to the daemon.
+}

src/common/session.ml

···
+open Capnp_rpc
+
+let or_fail = function
+  | Ok v -> v
+  | Error (`Capnp e) -> Fmt.failwith "%a" Capnp_rpc.Error.pp e
+
+let local ~stdin ~stdout ~stderr =
+  let module X = Raw.Service.Session in
+  X.local
+  @@ object
+       inherit X.service
+
+       method stdout_impl _ release_param_caps =
+         let open X.Stdout in
+         release_param_caps ();
+         let s = stdout () in
+         let response, results = Service.Response.create Results.init_pointer in
+         Results.output_set results s;
+         Service.return response
+
+       method stderr_impl _ release_param_caps =
+         let open X.Stderr in
+         release_param_caps ();
+         let s = stderr () in
+         let response, results = Service.Response.create Results.init_pointer in
+         Results.output_set results s;
+         Service.return response
+
+       method stdin_impl params release_param_caps =
+         let open X.Stdin in
+         let data = Params.input_get params in
+         release_param_caps ();
+         stdin data;
+         Service.return_empty ()
+     end
+
+module X = Raw.Client.Session
+
+type t = X.t Capability.t
+
+let stdout t () =
+  let open X.Stdout in
+  let request = Capability.Request.create_no_args () in
+  let result = Capability.call_for_value t method_id request |> or_fail in
+  Results.output_get result
+
+let stderr t () =
+  let open X.Stderr in
+  let request = Capability.Request.create_no_args () in
+  let result = Capability.call_for_value t method_id request |> or_fail in
+  Results.output_get result
+
+let stdin t input =
+  let open X.Stdin in
+  let request, params = Capability.Request.create Params.init_pointer in
+  Params.input_set params input;
+  Capability.call_for_unit t method_id request |> or_fail

src/common/shelter_common.ml

···
+let or_fail = function Ok v -> v | Error (`Msg m) -> failwith m
+
+module Raw = Raw
+module Admin = Admin
+module User = User
+module Session = Session

src/common/user.ml

···
+open Capnp_rpc
+
+let v sr connect =
+  let module X = Raw.Service.User in
+  Capnp_rpc.Persistence.with_sturdy_ref sr X.local
+  @@ object
+       inherit X.service
+
+       method connect_impl params release_param_caps =
+         let open X.Connect in
+         let config =
+           Params.config_get params |> Yojson.Safe.from_string
+           |> Config.of_yojson |> Result.get_ok
+         in
+         release_param_caps ();
+         let cap = connect config in
+         let response, results = Service.Response.create Results.init_pointer in
+         Results.cap_set results (Some cap);
+         Capability.dec_ref cap;
+         Service.return response
+     end
+
+module X = Raw.Client.User
+
+type t = X.t Capability.t
+
+let connect t config =
+  let open X.Connect in
+  let request, params = Capability.Request.create Params.init_pointer in
+  Params.config_set params (Config.to_yojson config |> Yojson.Safe.to_string);
+  Capability.call_for_caps t method_id request Results.cap_get_pipelined

src/shelterd/dune

···
+(executable
+ (name main)
+ (public_name shelterd)
+ (libraries eio_main shelter_common capnp-rpc-unix index.unix))

src/shelterd/main.ml

···
+open Shelter_common
+open Capnp_rpc
+
+module Admin = struct
+  module Secret = Capnp_rpc_net.Restorer.Id
+
+  let add_user t restorer name =
+    match Store.lookup t name with
+    | Some _ -> Fmt.failwith "User %s already exists!" name
+    | None -> (
+        let secret = Store.add_client t name in
+        match Capnp_rpc_net.Restorer.restore restorer secret with
+        | Ok v -> v
+        | Error exn ->
+            Fmt.failwith "%a" Capnp_rpc_proto.Error.pp (`Exception exn))
+
+  let remove_user t name = Store.remove t name
+
+  let v sr restorer t =
+    let add_user = add_user t restorer in
+    let remove_user = remove_user t in
+    Admin.v ~add_user ~remove_user sr
+end
+
+open Capnp_rpc_net
+
+let export ~secrets_dir ~vat ~name id =
+  let ( / ) = Filename.concat in
+  let path = secrets_dir / (name ^ ".cap") in
+  Capnp_rpc_unix.Cap_file.save_service vat id path |> or_fail;
+  Logs.app (fun f -> f "Wrote capability reference to %S" path)
+
+let daemon capnp services store secrets_dir =
+  let restore = Restorer.of_table services in
+  let admin_id = Capnp_rpc_unix.Vat_config.derived_id capnp "admin" in
+  let admin =
+    let sr = Capnp_rpc_net.Restorer.Table.sturdy_ref services admin_id in
+    Admin.v sr restore store
+  in
+  Restorer.Table.add services admin_id admin;
+  Eio.Switch.run @@ fun sw ->
+  let vat = Capnp_rpc_unix.serve capnp ~sw ~restore in
+  export ~secrets_dir ~vat ~name:"admin" admin_id;
+  Logs.app (fun f -> f "shelterd running...");
+  Eio.Promise.await (Eio.Promise.create () |> fst)
+
+open Cmdliner
+
+let setup_log style_renderer level =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter (Logs_fmt.reporter ());
+  ()
+
+let setup_log =
+  let docs = Manpage.s_common_options in
+  Term.(
+    const setup_log $ Fmt_cli.style_renderer ~docs () $ Logs_cli.level ~docs ())
+
+let admin =
+  Arg.required
+  @@ Arg.opt Arg.(some file) None
+  @@ Arg.info ~doc:"Path of the admin capability." ~docv:"ADDR"
+       [ "c"; "connect" ]
+
+let username =
+  Arg.required
+  @@ Arg.pos 0 Arg.(some string) None
+  @@ Arg.info ~doc:"The name of the new user to add." ~docv:"NAME" []
+
+let daemon env =
+  let doc = "run the shelter daemon" in
+  let man =
+    [
+      `S Manpage.s_description;
+      `P "The shelter daemon provides a way to run sessions for shelter users.";
+    ]
+  in
+  let info = Cmd.info ~man "daemon" ~doc in
+  let daemon () capnp =
+    let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri capnp in
+    let connect = Obj.magic () in
+    let load ~validate:_ ~sturdy_ref =
+      let sr = Capnp_rpc.Sturdy_ref.cast sturdy_ref in
+      Restorer.grant (User.v sr connect)
+    in
+    let loader = Store.create ~make_sturdy ~load "shelter.index" in
+    Eio.Switch.run @@ fun sw ->
+    let services = Restorer.Table.of_loader ~sw (module Store) loader in
+    daemon capnp services loader.store "./secrets"
+  in
+  let term =
+    Term.(const daemon $ setup_log $ Capnp_rpc_unix.Vat_config.cmd env)
+  in
+  (Cmd.v info term, term)
+
+let add_cmd env =
+  let doc = "add a new client" in
+  let man =
+    [
+      `S Manpage.s_description;
+      `P
+        "Add a new client and get a capablity back to use for that client to \
+         run shelter sessions.";
+    ]
+  in
+  let info = Cmd.info ~man "add" ~doc in
+  let add () cap_path name =
+    Eio.Switch.run @@ fun sw ->
+    let vat = Capnp_rpc_unix.client_only_vat ~sw env#net in
+    let sr = Capnp_rpc_unix.Cap_file.load vat cap_path |> or_fail in
+    Capnp_rpc_unix.with_cap_exn sr @@ fun service ->
+    let cap = Shelter_common.Admin.add_user service name in
+    Capability.with_ref cap @@ fun client ->
+    let uri = Persistence.save_exn client in
+    Fmt.pr "%a" Uri.pp uri
+  in
+  Cmd.v info Term.(const add $ setup_log $ admin $ username)
+
+let () =
+  Eio_main.run @@ fun env ->
+  let doc = "Shelterd" in
+  let man =
+    [
+      `S Manpage.s_authors;
+      `P "Patrick Ferris";
+      `S Manpage.s_bugs;
+      `P "Email bug reports to <[e-mail]>.";
+    ]
+  in
+  let info = Cmd.info ~doc ~man "shelterd" in
+  let daemon_cmd, daemon_term = daemon env in
+  exit
+    (Cmd.eval @@ Cmd.group ~default:daemon_term info [ daemon_cmd; add_cmd env ])

src/shelterd/store.ml

···
+(* let () = Mirage_crypto_rng_lwt.initialize (module Mirage_crypto_rng.Fortuna) *)
+let hash_size = 256
+
+module Fixed_string = Index.Key.String_fixed (struct
+  let length = 256
+end)
+
+module I = Index_unix.Make (Fixed_string) (Fixed_string) (Index.Cache.Noop)
+module Secret = Capnp_rpc_net.Restorer.Id
+
+type t = {
+  store : I.t;
+  make_sturdy : Secret.t -> Uri.t;
+  load :
+    validate:(unit -> bool) ->
+    sturdy_ref:[ `Generic ] Capnp_rpc.Sturdy_ref.t ->
+    Capnp_rpc_net.Restorer.resolution;
+}
+
+let create ~make_sturdy ~load path =
+  let store = I.v ~log_size:4096 path in
+  { store; make_sturdy; load }
+
+let pad_name name =
+  let diff = hash_size - String.length name in
+  if diff >= 0 then String.make diff ' ' ^ name else failwith "Name too long!"
+
+let add_client t name =
+  let name = String.trim name in
+  let secret = Secret.generate () in
+  let hash = Secret.digest `SHA256 secret in
+  let name = pad_name name in
+  let store_secret = pad_name hash in
+  I.replace t name store_secret;
+  I.replace t store_secret name;
+  I.merge t;
+  secret
+
+let lookup t name =
+  let name = pad_name name in
+  try Some (I.find t name) with Not_found -> None
+
+let lookup_by_hash t digest =
+  try Some (I.find t (pad_name digest)) with Not_found -> None
+
+let remove t name =
+  let name = String.trim name in
+  let padded_name = pad_name name in
+  I.filter t (fun (k, _) -> k = padded_name);
+  I.merge t
+
+let list t =
+  let lst = ref [] in
+  I.iter (fun k _ -> lst := String.trim k :: !lst) t;
+  List.stable_sort String.compare !lst
+
+module type T = Capnp_rpc_net.Restorer.LOADER
+
+let hash _ = `SHA256
+let make_sturdy t = t.make_sturdy
+
+let validate t digest () =
+  match lookup t.store digest with None -> false | Some _ -> true
+
+let load t self digest =
+  Logs.info (fun f -> f "Looking up %s" digest);
+  match lookup_by_hash t.store digest with
+  | None -> Capnp_rpc_net.Restorer.unknown_service_id
+  | Some _ ->
+      t.load ~validate:(validate t digest)
+        ~sturdy_ref:(Capnp_rpc.Sturdy_ref.cast self)