blob: 4c4e4b53fd2ae8e9fc9b4bdbdc22974b0dace217 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
(** System assembly: registry-based configuration dispatch. This module is the
composition root. It owns the mapping from configuration tags to concrete
implemenations and assembles a server from a configuration file. *)
type storage_parcel =
| StorageParcel :
(module Management.Physical.S with type t = 't and type error = string)
* 't
-> storage_parcel
type transport_parcel =
| TransportParcel :
(module Transport.TRANSPORT with type t = 't) * 't
-> transport_parcel
type storage_provider = Sexplib.Sexp.t -> (storage_parcel, string) result
type transport_provider = Sexplib.Sexp.t -> (transport_parcel, string) result
type registry = {
storage : storage_provider Utilities.StringMap.t;
transport : transport_provider Utilities.StringMap.t;
}
let registry : registry =
let open Utilities.StringMap in
{
storage =
empty
|> add "memory" (fun sexp ->
let ( let* ) = Result.bind in
let* config = Management.Physical.MemoryBackend.parse sexp in
let* storage = Management.Physical.Memory.create config in
Ok (StorageParcel ((module Management.Physical.Memory), storage)));
transport =
empty
|> add "tcp" (fun sexp ->
let ( let* ) = Result.bind in
let* config = Transport.TCP.parse sexp in
let transport = Transport.TCP.create config in
Ok (TransportParcel ((module Transport.TCP), transport)));
}
let assemble (config : Configuration.t) : (unit -> unit, string) result =
let open Utilities.Result in
let* storage_tag, storage_body =
Configuration.require_section ~name:"storage"
~valid_tags:(Utilities.StringMap.bindings registry.storage |> List.map fst)
config
in
let* storage_provider =
Utilities.StringMap.find_opt storage_tag registry.storage
|> Option.to_result
~none:(Printf.sprintf "Unknown storage backend: %s" storage_tag)
in
let* packed_storage = storage_provider storage_body in
let* transport_tag, transport_body =
Configuration.require_section ~name:"transport"
~valid_tags:
(Utilities.StringMap.bindings registry.transport |> List.map fst)
config
in
let* transport_provider =
Utilities.StringMap.find_opt transport_tag registry.transport
|> Option.to_result
~none:(Printf.sprintf "Unknown transport backend: %s" transport_tag)
in
let* packed_transport = transport_provider transport_body in
let (StorageParcel ((module S), storage)) = packed_storage in
let (TransportParcel ((module T), transport)) = packed_transport in
let module L = Listener.Make (T) (S) in
Ok (fun () -> L.run transport storage)
let run_from_config (path : string) : (unit -> unit, string) result =
let ( let* ) = Result.bind in
let* config =
Configuration.load ~expected_keys:[ "storage"; "transport" ] path
in
assemble config
|
