this repo has no description
Capnp part 1
+387
src/bin/dune
src/shelter/bin/dune
src/bin/dune
src/shelter/bin/dune
src/bin/main.ml
src/shelter/bin/main.ml
src/bin/main.ml
src/shelter/bin/main.ml
+44
src/common/admin.ml
+44
src/common/admin.ml
···
1
+
open Capnp_rpc
2
+
3
+
let v sr ~add_user ~remove_user =
4
+
let module X = Raw.Service.Admin in
5
+
Capnp_rpc.Persistence.with_sturdy_ref sr X.local
6
+
@@ object
7
+
inherit X.service
8
+
9
+
method add_user_impl params release_param_caps =
10
+
let open X.AddUser in
11
+
let id = Params.user_get params in
12
+
release_param_caps ();
13
+
let cap = add_user id in
14
+
let response, results = Service.Response.create Results.init_pointer in
15
+
Results.cap_set results (Some cap);
16
+
Capability.dec_ref cap;
17
+
Service.return response
18
+
19
+
method remove_user_impl params release_param_caps =
20
+
let open X.RemoveUser in
21
+
let id = Params.user_get params in
22
+
release_param_caps ();
23
+
remove_user id;
24
+
Service.return @@ Service.Response.create_empty ()
25
+
end
26
+
27
+
module X = Raw.Client.Admin
28
+
29
+
type t = X.t Capability.t
30
+
31
+
let add_user t user =
32
+
let open X.AddUser in
33
+
let request, params = Capability.Request.create Params.init_pointer in
34
+
Params.user_set params user;
35
+
Capability.call_for_caps t method_id request Results.cap_get_pipelined
36
+
37
+
let remove_user t user =
38
+
let open X.RemoveUser in
39
+
let request, params = Capability.Request.create Params.init_pointer in
40
+
Params.user_set params user;
41
+
let _ : _ StructStorage.reader_t =
42
+
Capability.call_for_value_exn t method_id request
43
+
in
44
+
()
+1
src/common/config.ml
+1
src/common/config.ml
···
1
+
type t = { shell : string; default_image : string } [@@deriving yojson]
+13
src/common/dune
+13
src/common/dune
+1
src/common/raw.ml
+1
src/common/raw.ml
···
1
+
include Schema.MakeRPC (Capnp_rpc)
+22
src/common/schema.capnp
+22
src/common/schema.capnp
···
1
+
@0x91b3108e7ebb3830;
2
+
interface Session {
3
+
stdin @0 (input :Text) -> ();
4
+
stdout @1 () -> (output :Text);
5
+
stderr @2 () -> (output :Text);
6
+
}
7
+
8
+
interface User {
9
+
connect @0 (config :Text) -> (cap :Session);
10
+
# Connect to the daemon and get a live session.
11
+
}
12
+
13
+
14
+
interface Admin {
15
+
addUser @0 (user :Text) -> (cap :User);
16
+
# Add a new user, returning a capability to act as a full
17
+
# Shelter user.
18
+
19
+
removeUser @1 (user :Text) -> ();
20
+
# Remove a user, this will also cancel existing connections
21
+
# this user may have to the daemon.
22
+
}
+57
src/common/session.ml
+57
src/common/session.ml
···
1
+
open Capnp_rpc
2
+
3
+
let or_fail = function
4
+
| Ok v -> v
5
+
| Error (`Capnp e) -> Fmt.failwith "%a" Capnp_rpc.Error.pp e
6
+
7
+
let local ~stdin ~stdout ~stderr =
8
+
let module X = Raw.Service.Session in
9
+
X.local
10
+
@@ object
11
+
inherit X.service
12
+
13
+
method stdout_impl _ release_param_caps =
14
+
let open X.Stdout in
15
+
release_param_caps ();
16
+
let s = stdout () in
17
+
let response, results = Service.Response.create Results.init_pointer in
18
+
Results.output_set results s;
19
+
Service.return response
20
+
21
+
method stderr_impl _ release_param_caps =
22
+
let open X.Stderr in
23
+
release_param_caps ();
24
+
let s = stderr () in
25
+
let response, results = Service.Response.create Results.init_pointer in
26
+
Results.output_set results s;
27
+
Service.return response
28
+
29
+
method stdin_impl params release_param_caps =
30
+
let open X.Stdin in
31
+
let data = Params.input_get params in
32
+
release_param_caps ();
33
+
stdin data;
34
+
Service.return_empty ()
35
+
end
36
+
37
+
module X = Raw.Client.Session
38
+
39
+
type t = X.t Capability.t
40
+
41
+
let stdout t () =
42
+
let open X.Stdout in
43
+
let request = Capability.Request.create_no_args () in
44
+
let result = Capability.call_for_value t method_id request |> or_fail in
45
+
Results.output_get result
46
+
47
+
let stderr t () =
48
+
let open X.Stderr in
49
+
let request = Capability.Request.create_no_args () in
50
+
let result = Capability.call_for_value t method_id request |> or_fail in
51
+
Results.output_get result
52
+
53
+
let stdin t input =
54
+
let open X.Stdin in
55
+
let request, params = Capability.Request.create Params.init_pointer in
56
+
Params.input_set params input;
57
+
Capability.call_for_unit t method_id request |> or_fail
+6
src/common/shelter_common.ml
+6
src/common/shelter_common.ml
+31
src/common/user.ml
+31
src/common/user.ml
···
1
+
open Capnp_rpc
2
+
3
+
let v sr connect =
4
+
let module X = Raw.Service.User in
5
+
Capnp_rpc.Persistence.with_sturdy_ref sr X.local
6
+
@@ object
7
+
inherit X.service
8
+
9
+
method connect_impl params release_param_caps =
10
+
let open X.Connect in
11
+
let config =
12
+
Params.config_get params |> Yojson.Safe.from_string
13
+
|> Config.of_yojson |> Result.get_ok
14
+
in
15
+
release_param_caps ();
16
+
let cap = connect config in
17
+
let response, results = Service.Response.create Results.init_pointer in
18
+
Results.cap_set results (Some cap);
19
+
Capability.dec_ref cap;
20
+
Service.return response
21
+
end
22
+
23
+
module X = Raw.Client.User
24
+
25
+
type t = X.t Capability.t
26
+
27
+
let connect t config =
28
+
let open X.Connect in
29
+
let request, params = Capability.Request.create Params.init_pointer in
30
+
Params.config_set params (Config.to_yojson config |> Yojson.Safe.to_string);
31
+
Capability.call_for_caps t method_id request Results.cap_get_pipelined
src/lib/dune
src/shelter/lib/dune
src/lib/dune
src/shelter/lib/dune
src/lib/engine.ml
src/shelter/lib/engine.ml
src/lib/engine.ml
src/shelter/lib/engine.ml
src/lib/history.ml
src/shelter/lib/history.ml
src/lib/history.ml
src/shelter/lib/history.ml
src/lib/passthrough/dune
src/shelter/lib/passthrough/dune
src/lib/passthrough/dune
src/shelter/lib/passthrough/dune
src/lib/passthrough/shelter_passthrough.ml
src/shelter/lib/passthrough/shelter_passthrough.ml
src/lib/passthrough/shelter_passthrough.ml
src/shelter/lib/passthrough/shelter_passthrough.ml
src/lib/passthrough/shelter_passthrough.mli
src/shelter/lib/passthrough/shelter_passthrough.mli
src/lib/passthrough/shelter_passthrough.mli
src/shelter/lib/passthrough/shelter_passthrough.mli
src/lib/script.ml
src/shelter/lib/script.ml
src/lib/script.ml
src/shelter/lib/script.ml
src/lib/shelter.ml
src/shelter/lib/shelter.ml
src/lib/shelter.ml
src/shelter/lib/shelter.ml
src/lib/shelter/config.ml
src/shelter/lib/shelter/config.ml
src/lib/shelter/config.ml
src/shelter/lib/shelter/config.ml
src/lib/shelter/diff.ml
src/shelter/lib/shelter/diff.ml
src/lib/shelter/diff.ml
src/shelter/lib/shelter/diff.ml
src/lib/shelter/dune
src/shelter/lib/shelter/dune
src/lib/shelter/dune
src/shelter/lib/shelter/dune
src/lib/shelter/fetch.ml
src/shelter/lib/shelter/fetch.ml
src/lib/shelter/fetch.ml
src/shelter/lib/shelter/fetch.ml
src/lib/shelter/opentrace
src/shelter/lib/shelter/opentrace
src/lib/shelter/opentrace
src/shelter/lib/shelter/opentrace
src/lib/shelter/runc.ml
src/shelter/lib/shelter/runc.ml
src/lib/shelter/runc.ml
src/shelter/lib/shelter/runc.ml
src/lib/shelter/shelter_main.ml
src/shelter/lib/shelter/shelter_main.ml
src/lib/shelter/shelter_main.ml
src/shelter/lib/shelter/shelter_main.ml
src/lib/shelter/shelter_main.mli
src/shelter/lib/shelter/shelter_main.mli
src/lib/shelter/shelter_main.mli
src/shelter/lib/shelter/shelter_main.mli
src/lib/shelter/store.ml
src/shelter/lib/shelter/store.ml
src/lib/shelter/store.ml
src/shelter/lib/shelter/store.ml
src/lib/shelter/tools.ml
src/shelter/lib/shelter/tools.ml
src/lib/shelter/tools.ml
src/shelter/lib/shelter/tools.ml
+4
src/shelterd/dune
+4
src/shelterd/dune
+134
src/shelterd/main.ml
+134
src/shelterd/main.ml
···
1
+
open Shelter_common
2
+
open Capnp_rpc
3
+
4
+
module Admin = struct
5
+
module Secret = Capnp_rpc_net.Restorer.Id
6
+
7
+
let add_user t restorer name =
8
+
match Store.lookup t name with
9
+
| Some _ -> Fmt.failwith "User %s already exists!" name
10
+
| None -> (
11
+
let secret = Store.add_client t name in
12
+
match Capnp_rpc_net.Restorer.restore restorer secret with
13
+
| Ok v -> v
14
+
| Error exn ->
15
+
Fmt.failwith "%a" Capnp_rpc_proto.Error.pp (`Exception exn))
16
+
17
+
let remove_user t name = Store.remove t name
18
+
19
+
let v sr restorer t =
20
+
let add_user = add_user t restorer in
21
+
let remove_user = remove_user t in
22
+
Admin.v ~add_user ~remove_user sr
23
+
end
24
+
25
+
open Capnp_rpc_net
26
+
27
+
let export ~secrets_dir ~vat ~name id =
28
+
let ( / ) = Filename.concat in
29
+
let path = secrets_dir / (name ^ ".cap") in
30
+
Capnp_rpc_unix.Cap_file.save_service vat id path |> or_fail;
31
+
Logs.app (fun f -> f "Wrote capability reference to %S" path)
32
+
33
+
let daemon capnp services store secrets_dir =
34
+
let restore = Restorer.of_table services in
35
+
let admin_id = Capnp_rpc_unix.Vat_config.derived_id capnp "admin" in
36
+
let admin =
37
+
let sr = Capnp_rpc_net.Restorer.Table.sturdy_ref services admin_id in
38
+
Admin.v sr restore store
39
+
in
40
+
Restorer.Table.add services admin_id admin;
41
+
Eio.Switch.run @@ fun sw ->
42
+
let vat = Capnp_rpc_unix.serve capnp ~sw ~restore in
43
+
export ~secrets_dir ~vat ~name:"admin" admin_id;
44
+
Logs.app (fun f -> f "shelterd running...");
45
+
Eio.Promise.await (Eio.Promise.create () |> fst)
46
+
47
+
open Cmdliner
48
+
49
+
let setup_log style_renderer level =
50
+
Fmt_tty.setup_std_outputs ?style_renderer ();
51
+
Logs.set_level level;
52
+
Logs.set_reporter (Logs_fmt.reporter ());
53
+
()
54
+
55
+
let setup_log =
56
+
let docs = Manpage.s_common_options in
57
+
Term.(
58
+
const setup_log $ Fmt_cli.style_renderer ~docs () $ Logs_cli.level ~docs ())
59
+
60
+
let admin =
61
+
Arg.required
62
+
@@ Arg.opt Arg.(some file) None
63
+
@@ Arg.info ~doc:"Path of the admin capability." ~docv:"ADDR"
64
+
[ "c"; "connect" ]
65
+
66
+
let username =
67
+
Arg.required
68
+
@@ Arg.pos 0 Arg.(some string) None
69
+
@@ Arg.info ~doc:"The name of the new user to add." ~docv:"NAME" []
70
+
71
+
let daemon env =
72
+
let doc = "run the shelter daemon" in
73
+
let man =
74
+
[
75
+
`S Manpage.s_description;
76
+
`P "The shelter daemon provides a way to run sessions for shelter users.";
77
+
]
78
+
in
79
+
let info = Cmd.info ~man "daemon" ~doc in
80
+
let daemon () capnp =
81
+
let make_sturdy = Capnp_rpc_unix.Vat_config.sturdy_uri capnp in
82
+
let connect = Obj.magic () in
83
+
let load ~validate:_ ~sturdy_ref =
84
+
let sr = Capnp_rpc.Sturdy_ref.cast sturdy_ref in
85
+
Restorer.grant (User.v sr connect)
86
+
in
87
+
let loader = Store.create ~make_sturdy ~load "shelter.index" in
88
+
Eio.Switch.run @@ fun sw ->
89
+
let services = Restorer.Table.of_loader ~sw (module Store) loader in
90
+
daemon capnp services loader.store "./secrets"
91
+
in
92
+
let term =
93
+
Term.(const daemon $ setup_log $ Capnp_rpc_unix.Vat_config.cmd env)
94
+
in
95
+
(Cmd.v info term, term)
96
+
97
+
let add_cmd env =
98
+
let doc = "add a new client" in
99
+
let man =
100
+
[
101
+
`S Manpage.s_description;
102
+
`P
103
+
"Add a new client and get a capablity back to use for that client to \
104
+
run shelter sessions.";
105
+
]
106
+
in
107
+
let info = Cmd.info ~man "add" ~doc in
108
+
let add () cap_path name =
109
+
Eio.Switch.run @@ fun sw ->
110
+
let vat = Capnp_rpc_unix.client_only_vat ~sw env#net in
111
+
let sr = Capnp_rpc_unix.Cap_file.load vat cap_path |> or_fail in
112
+
Capnp_rpc_unix.with_cap_exn sr @@ fun service ->
113
+
let cap = Shelter_common.Admin.add_user service name in
114
+
Capability.with_ref cap @@ fun client ->
115
+
let uri = Persistence.save_exn client in
116
+
Fmt.pr "%a" Uri.pp uri
117
+
in
118
+
Cmd.v info Term.(const add $ setup_log $ admin $ username)
119
+
120
+
let () =
121
+
Eio_main.run @@ fun env ->
122
+
let doc = "Shelterd" in
123
+
let man =
124
+
[
125
+
`S Manpage.s_authors;
126
+
`P "Patrick Ferris";
127
+
`S Manpage.s_bugs;
128
+
`P "Email bug reports to <patrick@sirref.org>.";
129
+
]
130
+
in
131
+
let info = Cmd.info ~doc ~man "shelterd" in
132
+
let daemon_cmd, daemon_term = daemon env in
133
+
exit
134
+
(Cmd.eval @@ Cmd.group ~default:daemon_term info [ daemon_cmd; add_cmd env ])
+71
src/shelterd/store.ml
+71
src/shelterd/store.ml
···
1
+
(* let () = Mirage_crypto_rng_lwt.initialize (module Mirage_crypto_rng.Fortuna) *)
2
+
let hash_size = 256
3
+
4
+
module Fixed_string = Index.Key.String_fixed (struct
5
+
let length = 256
6
+
end)
7
+
8
+
module I = Index_unix.Make (Fixed_string) (Fixed_string) (Index.Cache.Noop)
9
+
module Secret = Capnp_rpc_net.Restorer.Id
10
+
11
+
type t = {
12
+
store : I.t;
13
+
make_sturdy : Secret.t -> Uri.t;
14
+
load :
15
+
validate:(unit -> bool) ->
16
+
sturdy_ref:[ `Generic ] Capnp_rpc.Sturdy_ref.t ->
17
+
Capnp_rpc_net.Restorer.resolution;
18
+
}
19
+
20
+
let create ~make_sturdy ~load path =
21
+
let store = I.v ~log_size:4096 path in
22
+
{ store; make_sturdy; load }
23
+
24
+
let pad_name name =
25
+
let diff = hash_size - String.length name in
26
+
if diff >= 0 then String.make diff ' ' ^ name else failwith "Name too long!"
27
+
28
+
let add_client t name =
29
+
let name = String.trim name in
30
+
let secret = Secret.generate () in
31
+
let hash = Secret.digest `SHA256 secret in
32
+
let name = pad_name name in
33
+
let store_secret = pad_name hash in
34
+
I.replace t name store_secret;
35
+
I.replace t store_secret name;
36
+
I.merge t;
37
+
secret
38
+
39
+
let lookup t name =
40
+
let name = pad_name name in
41
+
try Some (I.find t name) with Not_found -> None
42
+
43
+
let lookup_by_hash t digest =
44
+
try Some (I.find t (pad_name digest)) with Not_found -> None
45
+
46
+
let remove t name =
47
+
let name = String.trim name in
48
+
let padded_name = pad_name name in
49
+
I.filter t (fun (k, _) -> k = padded_name);
50
+
I.merge t
51
+
52
+
let list t =
53
+
let lst = ref [] in
54
+
I.iter (fun k _ -> lst := String.trim k :: !lst) t;
55
+
List.stable_sort String.compare !lst
56
+
57
+
module type T = Capnp_rpc_net.Restorer.LOADER
58
+
59
+
let hash _ = `SHA256
60
+
let make_sturdy t = t.make_sturdy
61
+
62
+
let validate t digest () =
63
+
match lookup t.store digest with None -> false | Some _ -> true
64
+
65
+
let load t self digest =
66
+
Logs.info (fun f -> f "Looking up %s" digest);
67
+
match lookup_by_hash t.store digest with
68
+
| None -> Capnp_rpc_net.Restorer.unknown_service_id
69
+
| Some _ ->
70
+
t.load ~validate:(validate t digest)
71
+
~sturdy_ref:(Capnp_rpc.Sturdy_ref.cast self)