coracle/sim/simulator.ml at master · nickbetteridge/coracle · GitHub

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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
open Common
open Io
open Yojson.Safe
open States

module Simulate =
  functor (C: Protocol.CONSENSUS) -> struct

  let trace_buffer = ref []

  let buffer_many flush jsons =
    match flush with
    | true -> pretty_to_channel ~std:true stdout (`List jsons)
    | false -> trace_buffer := jsons @ !trace_buffer

  let buffer flush json = buffer_many flush [json]


  let json_to_stdout json =
    to_channel ~std:true stdout json

  let flush_buffer general client protocol =
    json_to_stdout (
      `Assoc [
        ("trace", `List !trace_buffer);
        ("results", `Assoc [
          ("network", general);
          ("client", client);
          ("protocol specific", protocol);
        ]);
      ])

  let input_event_to_json time id event =
    `Assoc [
      ("time", `Int time);
      ("id", `Int id);
      ("event", input_to_json C.msg_to_json event);
    ]

  let output_event_to_json time id event =
    `Assoc [
      ("time", `Int time);
      ("id", `Int id);
      ("event", output_to_json C.msg_to_json event);
    ]

  let output_events_to_json time id events =
    List.map (output_event_to_json time id) events


  let state_to_json time id state =
    `Assoc [
     ("time", `Int time);
     ("id", `Int id);
     ("event", C.Server.state_to_json state); ]

  let client_state_to_json time id state =
    `Assoc [
     ("time", `Int time);
     ("id", `Int id);
     ("event", C.Client.state_to_json state); ]

  let rec run ss mss es trace output_file global term debug =
    let rec eval ss mss es g =
      let open Events in
      match Events.next es with
      | Next ((t,n,e),new_es) ->
        let g = C.set_state t n g in
        if trace then buffer debug (input_event_to_json t n e) else (); (
        match e with
        | LocalArrival _ | LocalTimeout -> (
          (* i am a local event *)
          match States.get n mss with
          | Server ms ->
             (* i am a server side application *)
             let (new_ms,new_e) = App.StateMachine.eval t e ms in
             eval ss (States.set_server n new_ms mss) (Events.add n t new_e new_es) g
          | Client ms ->
             (* i am a client side application *)
             let (new_ms,new_e) = App.Client.eval t e ms in
             eval ss (States.set_client n new_ms mss) (Events.add n t new_e new_es) g
          )
        | _ -> (
          (* i am not a local event *)
          match States.get n ss with
          | Server s ->
            (* i am a server *)
            let (new_s,new_e,new_g) = C.Server.eval e s g in
            if trace then buffer_many debug (output_events_to_json t n new_e) else ();
            (
            match trace, new_s with
            | true, Some state -> buffer debug (state_to_json t n state)
            | _ -> ()
            );
            eval (States.set_server n new_s ss) mss (Events.add n t new_e new_es) new_g
          | Client s ->
            (* i am a client *)
            let (new_s,new_e,new_g) = C.Client.eval e s g in
            if trace then buffer_many debug (output_events_to_json t n new_e) else ();
            (
            match trace, new_s with
            | true, Some state -> buffer debug (client_state_to_json t n state)
            | _ -> ()
            );
            eval (States.set_client n new_s ss) mss (Events.add n t new_e new_es) new_g
            ))
      | NoNext new_es ->
        flush_buffer (Events.json_of_stats new_es) (App.json_of_stats term (States.clients mss) (States.servers mss)) (C.global_to_json g) in
    eval ss mss es global

  let start config_file trace output_file no_sanity debug =
    let json = Json_handler.json_from_file config_file in
    let para = Json_handler.parameters_from_json json in
    let protocol_json = Json_handler.proto_json_from_json json in
    let servers = Network.count_servers para.network in
    let clients = Network.count_clients para.network in
    if no_sanity then () else Parameters.check_sanity para;
    Numbergen.init para.seed;
    let config = C.parse_config servers clients protocol_json in
    let ss = States.init
      ~server_init:(fun n -> C.Server.init n config)
      ~client_init:(fun n -> C.Client.init n config) servers clients in
    let mss = States.init
      ~server_init:(App.StateMachine.init para)
      ~client_init:(App.Client.init para) servers clients in
    run ss mss (Events.init para) trace output_file C.reset_global para.term debug

end