Docstoc

Opis Internals

Document Sample
Opis Internals Powered By Docstoc
					  Opis Internals

Pierre-Evariste Dagand

   August 18, 2008
2
Introduction

This book is the literate code of Opis: it aims at providing the most up-to-date reference of our implemen-
tation. It describes the complete code base, without omission. Therefore, the reader is not expected to read
it from the beginning to the end: one should pick the parts in which one is interested, with no particular
order.
    For the reader that aims at implementing a distributed system in Opis, we advise to first read Part I
that describes the combinators. Then, the reader can jump to Chapter 26 which is an in-depth tutorial
implementing a Ping-pong protocol. During this reading, it is wise to keep an eye on Part II that defines
the interface from event functions to the real world.
    Although the code is mature, the literate comments are, in some places, rudimentary. Hence, this book
must be read as a draft and not as a final version. We will update it frequently as its literacy improves. And
we will gladly receive any feedback from readers and will do our best to address these comments.
    Good reading !




                                                     3
4
Contents

I    Arrow Combinators                                                                                                                                                             13
1 Module Event function                                                                                                                                                            15
  1.1 Profiling Support . . . . . . . . . . . . . . .               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   15
  1.2 The container Type . . . . . . . . . . . . .                 .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   15
      1.2.1 Profiler Specific . . . . . . . . . . . .                .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   15
      1.2.2 Embedding to avoid side-effects . . .                   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   16
  1.3 The arrow type . . . . . . . . . . . . . . . .               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   16
      1.3.1 A simple, object-oriented version . .                  .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   17
      1.3.2 An extended, object-oriented version                   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   17
      1.3.3 An extended, efficient version . . . .                   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   18
  1.4 Arrow Combinators . . . . . . . . . . . . .                  .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   18
      1.4.1 Base Arrow . . . . . . . . . . . . . .                 .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   18
      1.4.2 The Choice Arrow . . . . . . . . . .                   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   23
      1.4.3 The Loop/Circuit Arrow . . . . . . .                   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   24
      1.4.4 The Monoid Arrow . . . . . . . . . .                   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   26
  1.5 Executing an Event Function . . . . . . . .                  .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   27


II   The Network Launcher                                                                                                                                                          29
2 Module Signatures                                                                                                                                                                31
  2.1 User Signature: . . . . . . . . . . .    .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   31
  2.2 Network Signature: . . . . . . . .       .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   31
      2.2.1 User-defined Network types          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   32
      2.2.2 Generic Network Interface .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   32
  2.3 Timer Signature . . . . . . . . . .      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   33
      2.3.1 User-defined Timer types .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   33
      2.3.2 Generic Timer Interface . .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   34

3 Module Network interface types                                                                               35
  3.1 Type definition . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 35
  3.2 Signature . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 36
  3.3 Pretty-printer . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 37

4 Module Timer interface          types                                                                           41
  4.1 Module import . . . .       . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 41
  4.2 Type definitions . . .       . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 41
  4.3 Pretty-printers . . . .     . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 42

                                                                   5
6                                                                                                                                                                              CONTENTS

5 Module Network hashtbl                                                                                                                                                                           43

6 Module Network interface                                                                                                                                                                         45
  6.1 Global structures . . . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   45
  6.2 Utilities . . . . . . . . . .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   46
  6.3 Connections . . . . . . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   46
  6.4 Interface definition . . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   48

7 Module Network timer                                                                                                                                                                             51
  7.1 Modules . . . . . . . .      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   51
  7.2 Global state . . . . . .     .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   51
  7.3 Utilities . . . . . . . .    .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   52
  7.4 Timer Interface . . . .      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   52

8 Module Network launcher                                                                                     55
  8.1 Type definitions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 55
  8.2 Pretty-printers . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 56
  8.3 Communication with Interfaces . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 56


III    The Simulator Launcher                                                                                                                                                                      59
9 Module Simulation signatures                                                                                                                                                                     61
  9.1 Simulated User Signature . .                 .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   61
      9.1.1 Type definitions . . .                  .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   61
      9.1.2 Pretty-printers . . . .                .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   61
      9.1.3 User interface . . . . .               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   62
  9.2 Simulated Timer Signature .                  .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   62
      9.2.1 Inner module . . . . .                 .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   62
      9.2.2 Type definitions . . .                  .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   62
      9.2.3 Pretty-printers . . . .                .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   63
      9.2.4 Timer interface . . . .                .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   63
  9.3 Simulation Properties . . . .                .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   63

10 Module Simulator network                                                                                                                                                                        65

11 Module Simulator         timer                                                                                   67
   11.1 Module imports      . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 67
   11.2 Utility . . . . .   . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 67
   11.3 Timer Interface     . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 68

12 Module Simulator launcher                                                                                                                                                                       69
   12.1 Type definitions . . . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   69
   12.2 Pretty-printers . . . . . .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   70
   12.3 Utility . . . . . . . . . . .      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   70
   12.4 Multiplexer . . . . . . . .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   73


IV    The Debugger Launcher                                                                                                                                                                        75
13 Module Debugger signatures                                                                                                                                                                      77
CONTENTS                                                                                                                                                                            7

14 Module Peer                                                                                                                                                                     79

15 Module Network map                                                                                                                                                              81

16 Module Debugger launcher                                                                                                                                                        83

17 Module Cli ast                                                                                                                                                                  87

18 Module Cli ast printer                                                                                                                                                          89

19 Module Cli ast exec                                                                                                                                                             93


V    The Model-Checker Launcher                                                                                                                                                   103
20 Module Modelchecker signatures                                                                               105
   20.1 Type definitions . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 106
   20.2 Pretty-printers . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 106
   20.3 Timer interface . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 106

21 Module Modelchecker peer                                                                                                                                                       109

22 Module Network map                                                                                                                                                             113

23 Module Modelchecker timer                                                                                      115
   23.1 Module imports . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 115
   23.2 Utility . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 115
   23.3 Timer Interface . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 116

24 Module Modelchecker                                                                                                                                                            117

25 Module Modelchecker launcher                                                                                                                                                   131


VI     Examples                                                                                                                                                                   133
26 The Ping-pong tutorial                                                                                                                                                         135
   26.1 Module Pingpong messages . . . . .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   135
   26.2 Module Pingpong timers . . . . . .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   135
        26.2.1 Type definition . . . . . . . .     .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   135
        26.2.2 Pretty-printer . . . . . . . . .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   135
   26.3 Module Pingpong user . . . . . . . .      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   136
        26.3.1 Type definitons . . . . . . . .     .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   136
        26.3.2 Pretty-printer . . . . . . . . .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   136
   26.4 Module Pingpong . . . . . . . . . . .     .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   137
        26.4.1 Messages definition . . . . . .     .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   138
        26.4.2 Input/Output management :          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   138
        26.4.3 Reacting to User inputs . . .      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   139
        26.4.4 Reacting to Network inputs .       .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   141
        26.4.5 Reacting to Timer inputs . .       .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   142
        26.4.6 Wiring the Pingpong . . . . .      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   142
   26.5 Module Pingpong simulated user . .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   143
8                                                                                                                                                           CONTENTS

           26.5.1 Type definitions . . . . . . . . .     .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   143
           26.5.2 Pretty-printers . . . . . . . . . .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   144
           26.5.3 Simulator Multiplexer interfaces      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   144
    26.6   Module Simulation properties . . . . . .     .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   144
    26.7   Module Pingpong modelchecking user .         .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   144
           26.7.1 Type definitions . . . . . . . . .     .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   145
           26.7.2 Pretty-printers . . . . . . . . . .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   145
           26.7.3 Simulator Multiplexer interfaces      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   145
    26.8   Module Modelchecking properties . . .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   145
    26.9   Module Property . . . . . . . . . . . . .    .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   146

27 The Chord Protocol                                                                                                                                                           149
   27.1 Module Hashing . . . . . . . . . . . . . . .            .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   149
        27.1.1 Type definition . . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   149
        27.1.2 Pretty printing . . . . . . . . . . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   149
        27.1.3 Hashing space definition . . . . . . .            .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   149
        27.1.4 Comparaison operators . . . . . . .              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   150
        27.1.5 Computation operator(s) . . . . . .              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   151
   27.2 Module Node . . . . . . . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   151
        27.2.1 Types definitions . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   151
        27.2.2 Pretty-printers . . . . . . . . . . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   151
        27.2.3 Methods on Node type . . . . . . . .             .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   152
   27.3 Module Successors . . . . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   152
        27.3.1 Type definition . . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   152
        27.3.2 Printer . . . . . . . . . . . . . . . . .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   153
        27.3.3 Constructors . . . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   153
        27.3.4 Accessor . . . . . . . . . . . . . . . .         .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   154
        27.3.5 Combinator . . . . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   154
        27.3.6 Insertion & Merge . . . . . . . . . .            .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   154
        27.3.7 Remove . . . . . . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   155
   27.4 Module Finger table . . . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   155
        27.4.1 Types definition . . . . . . . . . . .            .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   156
        27.4.2 Pretty-printing . . . . . . . . . . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   156
        27.4.3 Instanciation functions . . . . . . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   156
        27.4.4 Insertion function . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   157
        27.4.5 Find successor . . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   158
        27.4.6 Find immediate predecessor . . . . .             .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   159
        27.4.7 Remove a node from the finger table               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   160
   27.5 Module Command type . . . . . . . . . . .               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   161
   27.6 Module Command type printers . . . . . .                .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   162
   27.7 Module Chord network messages . . . . . .               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   164
   27.8 Module Chord simulated user . . . . . . .               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   165
        27.8.1 Simulation parameters . . . . . . . .            .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   165
        27.8.2 Types definitions . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   165
        27.8.3 Pretty-printing . . . . . . . . . . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   165
        27.8.4 Interface to the multiplexer . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   166
   27.9 Module Chord timers . . . . . . . . . . . .             .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   166
        27.9.1 Type definition . . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   166
        27.9.2 Pretty-printing . . . . . . . . . . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   167
CONTENTS                                                                                                                                                                              9

   27.10Module Chord . . . . . . . . . . .      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   167
        27.10.1 Parameters initialization . .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   168
        27.10.2 Basic functions . . . . . . .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   168
        27.10.3 Interpret input . . . . . . .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   168
        27.10.4 Mainteners . . . . . . . . .    .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   171
        27.10.5 Reactions . . . . . . . . . .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   176
        27.10.6 Final Wiring . . . . . . . .    .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   183
   27.11Module Chord modelnet user . . .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   183
        27.11.1 Simulation parameters . . .     .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   183
        27.11.2 Types definitions . . . . . .    .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   184
        27.11.3 Pretty-printing . . . . . . .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   184
        27.11.4 Interface to the multiplexer    .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   184
   27.12Module Simulation properties . . .      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   185

28 Generic Gossip Protocol                                                                                    187
   28.1 Module Gossip signatures . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 187
   28.2 Module Gossip . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 188

29 The  Cyclon Protocol                                                                                                                                                             191
   29.1 Module Cyclon view . . . . . . . . . . . .              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   191
   29.2 Module Cyclon network messages . . . .                  .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   192
   29.3 Module Cyclon timers . . . . . . . . . . .              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   193
        29.3.1 Type definition . . . . . . . . . . .             .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   193
        29.3.2 Pretty-printer . . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   193
   29.4 Module Cyclon user . . . . . . . . . . . .              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   193
        29.4.1 Type definitions . . . . . . . . . .              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   194
        29.4.2 Pretty-printers . . . . . . . . . . .            .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   194
        29.4.3 Simulator Multiplexer interfaces .               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   194
   29.5 Module Cyclon lib . . . . . . . . . . . . .             .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   194
        29.5.1 General parameters . . . . . . . .               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   195
        29.5.2 Types declarations . . . . . . . . .             .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   195
        29.5.3 Interpret inputs . . . . . . . . . . .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   196
        29.5.4 Maintainance . . . . . . . . . . . .             .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   197
        29.5.5 React . . . . . . . . . . . . . . . .            .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   197
   29.6 Module Cyclon . . . . . . . . . . . . . . .             .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   199
   29.7 Module Cyclon simulated user . . . . . .                .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   200
        29.7.1 Type definitions . . . . . . . . . .              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   200
        29.7.2 Pretty-printers . . . . . . . . . . .            .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   200
        29.7.3 Simulator Multiplexer interfaces .               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   201
   29.8 Module Cyclon simulation properties . .                 .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   201
   29.9 Module Cyclon modelchecking user . . .                  .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   201
        29.9.1 Type definitions . . . . . . . . . .              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   202
        29.9.2 Pretty-printers . . . . . . . . . . .            .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   202
        29.9.3 Simulator Multiplexer interfaces .               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   202
   29.10Module Cyclon modelchecking properties                  .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   203
   29.11Module Cyclon property . . . . . . . . . .              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   203
10                                                                                                                                                                               CONTENTS

30 The      Vicinity Protocol                                                                                                                                                                        207
   30.1     Module Vicinity view . . . . . . . . . .                         .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   207
   30.2     Module Vicinity network messages . . .                           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   210
   30.3     Module Vicinity timers . . . . . . . . .                         .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   211
            30.3.1 Type definition . . . . . . . . . .                        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   211
            30.3.2 Pretty-printer . . . . . . . . . . .                      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   211
     30.4   Module Vicinity user . . . . . . . . . . .                       .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   211
            30.4.1 Type definitions . . . . . . . . .                         .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   211
            30.4.2 Pretty-printers . . . . . . . . . .                       .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   212
            30.4.3 Simulator Multiplexer interfaces                          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   212
     30.5   Module Vicinity lib . . . . . . . . . . .                        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   212
            30.5.1 General parameters . . . . . . .                          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   212
            30.5.2 Types declarations . . . . . . . .                        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   213
            30.5.3 Interpret inputs . . . . . . . . . .                      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   214
            30.5.4 Maintainance . . . . . . . . . . .                        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   214
            30.5.5 React . . . . . . . . . . . . . . .                       .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   215
     30.6   Module Vicinity . . . . . . . . . . . . . .                      .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   216
     30.7   Module Vicinity simulated user . . . .                           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   218
            30.7.1 Type definitions . . . . . . . . .                         .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   218
            30.7.2 Pretty-printers . . . . . . . . . .                       .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   218
            30.7.3 Simulator Multiplexer interfaces                          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   219
     30.8   Module Vicinity simulation properties .                          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   219

31 The Cyclonity Protocol                                                                                                                                                                            221
   31.1 Module Cyclonity network messages . .                                .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   221
   31.2 Module Cyclonity timers . . . . . . . .                              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   221
        31.2.1 Type definition . . . . . . . . . .                            .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   221
        31.2.2 Pretty-printer . . . . . . . . . . .                          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   222
   31.3 Module Cyclonity user . . . . . . . . . .                            .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   222
        31.3.1 Type definitions . . . . . . . . .                             .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   222
        31.3.2 Pretty-printers . . . . . . . . . .                           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   222
        31.3.3 Simulator Multiplexer interfaces                              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   223
   31.4 Module Cyclonity . . . . . . . . . . . . .                           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   223
   31.5 Module Cyclonity simulated user . . . .                              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   225
        31.5.1 Type definitions . . . . . . . . .                             .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   225
        31.5.2 Pretty-printers . . . . . . . . . .                           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   225
        31.5.3 Simulator Multiplexer interfaces                              .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   226
   31.6 Module Cyclonity simulation properties                               .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   226

A General Utilities                                                                                                                                                                                  227
  A.1 Module Hash . . . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   227
  A.2 Module Net general .           .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   227
  A.3 Module Tcp . . . . . .         .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   228
  A.4 Module Udp . . . . . .         .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   228
  A.5 Module Int to inet . .         .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   228
  A.6 Module Priority queue          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   229
  A.7 Types definition . . .          .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   229
  A.8 Pretty printer . . . . .       .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   230
  A.9 Constructor . . . . . .        .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   231
  A.10 Combinators . . . . .         .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   .   231
CONTENTS                                                                                                     11

B Debugger Parser/Lexer                                                                                      235
  B.1 Module Cli parser (Yacc) . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 235
  B.2 Module Cli lexer (Lex) . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 237
12   CONTENTS
      Part I

Arrow Combinators




        13
Chapter 1

Module Event function

This module implements the Arrow combinators that are used to build the event function out of pure
functions. As an aside, this combinator abstraction is instrumented for profiling, model-checking, and so on.



1.1     Profiling Support
For example, the profiling support of Opis is provided at the combinator level. At this level, profiling consists
in filling a file with the input size, output size and processing time of each executed pure functions. Hence,
we define a profile file and a switch to turn profiling On or Off.
let profile file = ref stdout
let profiling = ref false
Finally, switching the profiling mode is done by set profiling. The profiling trace is written in a file which
name corresponds to the name of the application, concatenated with the .prof suffix.
let set profiling profiling on =
   profiling := profiling on ;
   if profiling on then
      let filename = Sys.argv .(0) in
         profile file := open out (filename ˆ ".prof")




1.2     The container Type
To build the (α, β) arrow type, we first need to define some useful types.


1.2.1    Profiler Specific
The first one is id that uniquely identifies an execution of the event function. This information is latter used
by the profiler.
type id = int
This id will be automatically defined by a counter that is incremented and returned at each access:

                                                      15
16                                                         CHAPTER 1. MODULE EVENT FUNCTION

let execution counter =
   let counter = ref 0 in
   let execution counter () =
      incr counter ;
      !counter
   in
      execution counter



1.2.2      Embedding to avoid side-effects
An event function is expected to be built upon pure functions only: for instance, side-effects should not be
used. Although this requirement is not of prime importance in normal, network use, this is a hardship if one
want to debug, simulate, or model-check one’s event function.
    Indeed, during model-checking, we expect reproducible results. For example, if the event function were to
call Random.int to get random numbers, then the model-checker cannot, easily, identify this state-branching
point and explore the various possibilities. As for the random numbers, time coud also be retrieved by
Unix .gettimeofday, at the expense of the reproducibility of executions during simulation, debugging and
model-checking.
    We have also chosen to broadcast a printer, that can be adequatly instrumented. It is mainly used during
simulation and debugging where several event functions are executed. Hence, we can instrument the printer
to provide some context about the printed message, such as the current time and the concerned peer. This
is helpful in understanding the interactions between peers. Note that printer is a side-effecting function:
one could also have considered implementing this functionality as a ”Writer monad” alike. For the sake of
simplicity and efficiency, we did not chosen this approach.
    Obviously, we also provide the input to the event function. To ease the manipulation of these 4 arguments,
plus the execution identifier, we define a container that will flow through the event function, with the args
field consequently updated along the journey.
type   time = float
type   rand = float → float
type   printer = string → unit
type   α args = α
type α container =
     { execution : id
     ; time : time
     ; rand : rand
     ; print : printer
     ; args : α args }
let copy container c args = { c with args = args }




1.3       The arrow type
Having defined the container type, we can go further and define our arrow type. Although we have im-
plemented our arrow type in Haskell with purely-functional constructs only, the efficiency of such design
in OCaml would not be satisfying. Therefore, we have decided to use OCaml-specific constructs (such as
1.3. THE ARROW TYPE                                                                                          17

objects or references) to get efficiency. To compensate the lack of purity, we provide operators that mimic
purity.



1.3.1    A simple, object-oriented version
Hence, our OCaml arrow is an object with:

   • a call method that takes a container and returns a list of containers

   • a clone method that duplicates the event function. Later, executing the event function will not affect
     the state of its copy, and vice-versa.

class type [α, β] oarrow =
object
   method call : α container → β container list
   method clone : (α, β) oarrow
end
The clone method solves our lack of purity. In Haskell, one would simply manipulate the event function as
any pure function and duplicate it by, for example, a simple let event function copy = event function.
Haskell’s event functions are referentially transparent.
    Here, as we will see later on, the loop combinator uses a ref cell: copying an OCaml event function by
its name will still side-effect on the shared reference cell, breaking the referential transparency. The clone
method computes a new event function, in the exact same state but with unrelated reference cells. Hence,
we can, explicitly, recover referential transparency.
    Note that these and later subtleties are not exposed to Opis developer but only used by launchers, to
manipulate the event functions. Launchers are supposed to be developed once and for all, by an experimented
Opis’ developer: we believe that this does not impair the safety offered by Opis.



1.3.2    An extended, object-oriented version
Although this implementation of the arrow type is sufficient for live deployment and simulation, model-
checking and debugging ask for an extension of this type. Indeed, we would like to be able to manipulate
the state contained in the event function: inspect them in the debugger, compute their signature to uniquely
identify them during model-checking, retrieve them to check safety properties, etc.
   Basically, a state is a value that must be remembered from one event function’s execution to another,
hence this name. A classical state is a routing table, for instance. Hence, the new arrow type is the following:
class type [α, β] ext arrow =
object
   inherit [α, β] oarrow
   method signature : unit → string
   method print state : Format.formatter → string → unit
   method get states : unit → ( string × Obj .t ) list
end
We have extended the previous type with:

   • a signature method that computes a signature uniquely identifying the current state of the event
     function. This is used during model-checking to avoid re-exploring already visited states.
18                                                           CHAPTER 1. MODULE EVENT FUNCTION

      • a print state method that pretty-prints the state associated with the given string. This is mainly used
        during debugging, to inspect the value of some crucial states. The labeling of states is done below,
        while defining the dloop combinator in Section 1.4.3.

      • a get states method that fetches all states and their respective label. This is used during model-
        checking, to write and check properties of the event function.

   Note that get states uses some OCaml black-magic, in the form of Obj .t. Although get states will only
be used while writing model-checking properties, the use of type-unsafe operations can arguably be critized.
Unless a better solution is found, we urge Opis’ user to carefully deal with this function.



1.3.3       An extended, efficient version
While the Object-oriented design leads to a clear and concise code, it implies a performance penalty that we
cannot afford. Therefore, we have re-written the objects above using records. This transformation clearly
improves performance, at the expense of code clarity.
type (α, β) arrow =
     { arrow : α container → β container list
     ; clone : unit → (α, β) arrow
     ; signature : unit → string
     ; print state : Format.formatter → string → unit
     ; get states : unit → ( string × Obj .t ) list }
As the arrow type is abstract, we explicitly provide these methods to the developer:
let   clone arrow f = f .clone ()
let   signature arrow f = f .signature ()
let   print state f ppf identifier = f .print state ppf identifier
let   get states f = f .get states ()




1.4        Arrow Combinators
The Arrow combinators are used to build event functions upon pure functions. We will describe their
OCaml implementation in the following. As in Haskell’s presentation, we separate the combinators into
specific instances of Arrow: we start with the Base one, which is expanded into the Choice Arrow and the
Loop + Circuit Arrow. Finally, we provide two combinators to manipulate event functions in a Monoid.



1.4.1       Base Arrow
The Base Arrow is composed by 3 combinators:

 arr f : encapsulates a pure function into an event function

 ef >>> eg: composes two event functions

 first ef : applies an event function to the first element of a pair, the other one remains intact
1.4. ARROW COMBINATORS                                                                                   19

Profiling support
The profiling capability of Opis rely on our capacity to precisely measure what are the arguments of each
pure functions and how long these functions take to process these inputs. Hence, we have instrumented the
arr combinator – which embeds the pure functions in the event function world – to log these informations.
   Here, we define some useful functions. The first one, get user time, will be used to measure the processing
time.
let get user time () = Unix .gettimeofday ()
anonymous counter uniquely identifies a pure function. It will be called when the arr combinator embeds
a function that has not been labeled by an explicit ˜name. In general, the developer should override this
default name by providing her own, intelligible label.
let anonymous counter =
   let counter = ref 0 in
   let anonymous counter () =
      incr counter ;
      "Anonymous#" ˆ (string of int !counter )
   in
      anonymous counter
To pretty-print the profiling informations, we define print profiling info. Note that it writes to the file
identified by the global variable !profile file.
let print profiling info id name execution time input size output size =
   Printf .fprintf
     !profile file
     "%10d\t%30s\t%10f\t%10d\t%10d\n"
     id
     name
     execution time
     input size
     output size
We also need to compute the size of the inputs and outputs of pure functions. This is achieved by the size
function:
let size x = Marshal .data size (Marshal .to string x [ Marshal .No sharing ; Marshal .Closures ]) 0
Finally, when one has to execute a pure function, we have to consider the profiling and non-profiling cases.
We write this code here, once and for all.
let exec function f name container input =
   let result =
      (∗ Are we profiling ? ∗)
      if ¬ !profiling then
         (∗ No, just compute the result: ∗)
         f input
      else
         (∗ Yes, chronometer the computation: ∗)
         let ( result , execution time ) =
            let start = get user time () in
            let result = f input in
               ( result , get user time () − . start )
20                                                            CHAPTER 1. MODULE EVENT FUNCTION

         in
            (∗ Then, measure the input and output sizes: ∗)
         let input size = size input in
         let output size = size result in
            (∗ And print these informations: ∗)
            print profiling info
               container .execution
               name
               execution time
               input size output size;
            (∗ Finally, return the result: ∗)
            result
  in
       (∗ Pass the container along, with the updated result: ∗)
       [ copy container container result ]



The arr combinator
Hence, we can define the arr combinator: it takes a function of type (time, rand , print, α) → β to build
an (α, β) arrow .
let rec arr ?(name = anonymous counter ()) f =
   { arrow = ( fun c →
                   let input = ( c.time , c.rand , c.print , c.args ) in
                      exec function f name c input )
   ; clone =
        (∗ Cloning is a simple recursive call, to build the very same object ∗)
        ( fun () → arr ˜name : name f )
   ; signature =
        (∗ A pure function does not hold any state: ∗)
        ( fun () → "" )
   ; print state = ( fun       → () )
   ; get states = ( fun () → [ ] ) }
However, most of the time, the embedded functions do not use the time, the random number generator
or the printer, they just use the input event. In a sense, the resulting event function is pure: we have
hijacked the pure combinator of Haskell to mark this difference. Hence, our pure combinator has type
(α → β) → (α, β) arrow
let pure ?(name = anonymous counter ()) f =
   let f ( , , , x ) = f x in
      arr ˜name : name f
Similarly, we provide the developer with 3 specialized arr * combinators, which give access to each field of
the container .
let arr timed ?(name = anonymous counter ()) f =
   let f ( time , , , x ) = f ( time , x ) in
      arr ˜name : name f
1.4. ARROW COMBINATORS                                                                                    21

let arr rand ?(name = anonymous counter ()) f =
   let f ( , rand , , x ) = f ( rand , x ) in
      arr ˜name : name f

let arr print ?(name = anonymous counter ()) f =
   let f ( , , print , x ) = f ( print , x ) in
      arr ˜name : name f

Therefore, we can already define some simple event functions:

let identity () = pure ˜name :"LibIdentity" ( fun c → c )
let constant b = pure ˜name :"LibConstant" ( fun → b )




The Composition combinator

Using the >>> combinator, we are able to compose two computations. Its implementation is the following:

let rec (>>>) ef eg =
   { arrow =
        (fun c →
            (∗ First, apply ef to the input: ∗)
            let args g = ef .arrow c in
               (∗ Then, apply eg to the list of results: ∗)
            let result g = List.map eg.arrow args g in
               (∗ And flatten these results in a single list: ∗)
               List.flatten result g )
   ; clone = (fun () →
                    (∗ Recursively, clone both objects and build a new composition: ∗)
                    ef .clone () >>> eg.clone ())
   ; signature = (fun () →
                          (∗ Concatenate then hash both objects signatures: ∗)
                          Hash.hash (ef .signature () ˆ eg.signature ()))
   ; print state = (fun ppf id →
                            (∗ Recursively, print the state in both objects: ∗)
                            ef .print state ppf id ;
                            eg.print state ppf id )
   ; get states = (fun () →
                           (∗ Recursively, get the states and concatenate them: ∗)
                           ef .get states () @ eg.get states () ) }




The First combinator

Using first ef , we apply ef to the first element of every pair of events sent to the resulting event function.
Its implementation is the following:
22                                                           CHAPTER 1. MODULE EVENT FUNCTION

let rec first ef =
   { arrow =
        (fun c →
            (∗ Extract the elements from the pair: ∗)
            let ( x , y ) = c.args in
               (∗ Create a container arround the first element: ∗)
            let x = copy container c x in
               (∗ Apply ef to this element: ∗)
            let results x = ef .arrow x in
               (∗ Build the resulting containers: ∗)
               List.map
                  (fun c → copy container c ( c.args , y ))
                  results x )
   ; clone = (fun () →
                     (∗ Recursively, clone and rebuild first ef : ∗)
                     first (ef .clone ()))
   ; signature = (fun () →
                          (∗ Recursively compute the signature: ∗)
                          ef .signature ())
   ; print state = (fun ppf id →
                             (∗ Recursively print the state: ∗)
                             ef .print state ppf id )
   ; get states = (fun () →
                           (∗ Recursively get the states: ∗)
                           ef .get states () ) }



Building upon the Base Arrow
Based on the combinators above and some pure functions, we are able to define the following, useful combi-
nators.


The second combinator: second ef does the same job than first but on the second element:
let swap () = pure ˜name :"LibSwap" ( fun ( x , y ) → ( y , x ) )
let second ef = swap () >>> first ef >>> swap ()
A careful reader will have notice the η-expansion of swap: due to the specifities of OCaml type system
(mainly due to the presence of references), we need to use eta-expansion to recover the polymorphism of
swap. Haskell, for instance, does not have this problem. However, in practice, we do not thing that this
technicality will burden the simplicity of Opis-based systems.


The $$$ combinator: ef $$$ eg is the (∗ ∗ ∗) combinator of Hughes : ef is applied to the first element of
the pair, while eg is applied to the second one. We diverge from Hughes notation because (∗∗∗) is interpreted
as a comment in OCaml.
let ($$$) ef eg = first ef >>> second eg
1.4. ARROW COMBINATORS                                                                                    23

The &&& combinator: ef &&& eg applies ef and eg to a unique input and return a pair composed of
the result of both computations:
let dup2 () = pure ˜name :"LibDup2" ( fun x → ( x , x ) )
let (&&&) ef eg = dup2 () >>> ( ef $$$ eg )



1.4.2    The Choice Arrow
Using the previous combinators, we are able to express a lot of computations. However, they do not allow
us to expose conditionals at the event function level.
    To do so, we first define the either type:
type (α, β) either =
  | Left of α
  | Right of β



The left combinator:
left ef applies ef if and only if the input event is tagged Left. Otherwise, the input event is passed along.
Its implementation is the following:
let rec left ef =
   { arrow =
        ( fun c →
              (∗ Is the input tagged Left ? ∗)
              match c.args with
                | Left x →
                      (∗ Yes, wrap it in a container: ∗)
                      let arg ef = copy container c x in
                         (∗ Compute the results: ∗)
                      let results ef = ef .arrow arg ef in
                         (∗ And re-tag the list of results: ∗)
                         List.map (fun c → copy container c (Left c.args)) results ef
                | Right x →
                      (∗ No, do nothing ∗)
                      [ copy container c (Right x ) ] )
   ; clone = (fun () → left (ef .clone ()))
   ; signature = (fun () → ef .signature ())
   ; print state = (fun ppf id → ef .print state ppf id )
   ; get states = (fun () → ef .get states () ) }



Building upon the Choice Arrow



The right combinator right ef does the same job than left but on the right side
24                                                         CHAPTER 1. MODULE EVENT FUNCTION

let mirror () = pure ˜name :"LibMirror"
   ( fun x →
        match x with
          | Left a → Right a
          | Right a → Left a )
let right ef = mirror () >>> left ef >>> mirror ()



The +++ combinator ef + + + eg applies ef if the input is tagged Left, eg if the input is tagged Right:
let (+ + +) ef eg = left ef >>> right eg



The ||| combinator ef ||| eg applies ef if the input is tagged Left, eg if the input is tagged Right and, in
both case, it untags the result, which must have the same type:
let untag () = pure ˜name :"LibUntag"
   ( fun x →
         match x with
            | Left a → a
            | Right a → a )
let (|||) ef eg = ef + + + eg >>> untag ()



1.4.3     The Loop/Circuit Arrow
dloop init ef passes a pair composed by the input and a feedback value to ef . For the first call of ef , the
feedback value is set to init.
    Note that, in Haskell, we would define dloop as : dloop init ef = loop ( second ( delay init ) >>> ef )
    Here, we have chosen to merge loop and delay in a single combinator because:
     • implementing the loop combinator in OCaml, a strict, call-by-value language, is not easy and would
       imply a performance penalty
     • two separate loop and delay combinators require a special attention for Opis’ user: a loop must never
       be used without a delay. Our dloop combinator removes this burden.
    We argue that this design choice does not lower our expressive power. And that it improves the quality
of the overhaul implementation while simplifying the use of loop/delay.


Manipulating States
The dloop combinator is used to contain a state. Therefore, methods like signature, print states and
get states are more complex here than in the previous combinators. Hence, we provide some specialized
functions.
   undefined printer is the default pretty-printer used by print states, unless specified otherwise:
let undefined printer ppf   =
   Format.fprintf ppf "(Undefined state pretty-printer)";
   Format.print newline ()
1.4. ARROW COMBINATORS                                                                                      25

signature computes the signature of the contained event function as well as the signature of the current state:
let signature ef state =
   Hash.hash (
      ( ef .signature () )
      ˆ ( Marshal .to string state [ Marshal .No sharing ; Marshal .Closures ] ) )



The dloop combinator

let rec dloop
      (∗ An identifier of the contained state: ∗)
      ?( state id = "undefined" )
      (∗ A pretty-printer for the contained state: ∗)
      ?( state printer = undefined printer )
      init ef =
   (∗ The state contained by this dloop: ∗)
   let state = ref init in
      { arrow =
           (fun c →
               (∗ Build a container with the input and the current feedback value: ∗)
               let arg ef = copy container c ( c.args , !state ) in
                  (∗ Split the list of results into the ouputs and states: ∗)
               let outputs , new states =
                  List.split
                     (List.map
                        (fun x → x .args)
                        (ef .arrow arg ef ))
               in
                  (∗ The last computed state will be the new, current state: ∗)
               let new state = List.nth new states (List.length new states − 1) in
                  (∗ Update the current state: ∗)
                  state := new state;
                  (∗ And wrap the results in a container: ∗)
                  List.map (fun x → copy container c x ) outputs )
      ; clone =
           (fun () →
               (∗ Clone the current !state: ∗)
               dloop
                  ˜state id : state id
                  ˜state printer : state printer
                  !state (ef .clone ()))
      ; signature = (fun () → signature ef !state )
      ; print state =
           (fun ppf id →
               (∗ Is id the id of this state ? ∗)
               if id = state id then
                  (∗ Yes, thus print it: ∗)
                  state printer ppf !state
26                                                             CHAPTER 1. MODULE EVENT FUNCTION

              else
                 (∗ No, recursively try to print it: ∗)
                 ef .print state ppf id )
     ; get states = (fun () →
                            (∗ Cons the current state to the states of ef : ∗)
                            ( state id , Obj .repr !state ) :: ef .get states () ) }



1.4.4     The Monoid Arrow
During our experimentations, we have felt the need to process a list of events as a sequence of events, hence
transforming a α list into a α, the burden of sequencing being transfered under the combinator level. This
resulted in a type-signature (α list,α) arrow that corresponds to the well-known mconcat function of Monoid ,
in Haskell.
   Therefore, we have implemented the Monoid combinators.


The mappend combinator
ef &&| eg applies ef and eg to a single input and merge the results on the wire: the two list of events are
successively and individualy treated by the following combinators.
let rec (&&|) ef eg =
   { arrow =
        (fun c →
            (∗ Apply ef and eg on the input: ∗)
            let ef results = ef .arrow c in
            let eg results = eg.arrow c in
               (∗ And concatenate both outputs: ∗)
               ef results @ eg results )
   ; clone = (fun () → ef .clone () &&| eg.clone () )
   ; signature = (fun () → Hash.hash ( ef .signature () ˆ eg.signature () ) )
   ; print state = (fun ppf id →
                           ef .print state ppf id ;
                           eg.print state ppf id )
   ; get states = (fun () → ef .get states () @ eg.get states () ) }
mconcat ef is generalization of (&&|) that transforms a α list into an α. Whereas we could have implemented
it using (&&|), we have chosen to sacrify aesthetics for performance.
let rec mconcat ef =
   { arrow =
        (fun c →
            (∗ Compute ef of the input: ∗)
            let results ef = ef .arrow c in
               (∗ Flatten the lists in the containers into a single list of containers: ∗)
               List.flatten
                  (List.map
                     (fun c →
                         List.map
                           (fun x → copy container c x )
1.5. EXECUTING AN EVENT FUNCTION                                                                        27

                         c.args)
                   results ef ) )
  ;   clone = (fun () → mconcat (ef .clone ()))
  ;   signature = (fun () → ef .signature ())
  ;   print state = (fun ppf id → ef .print state ppf id )
  ;   get states = (fun () → ef .get states ()) }




1.5       Executing an Event Function
Finally, we need to be able to run a given event function, at a given time, with a given random number
generator, printer and arguments. This execution will process the list of input events and return a list of
output commands. Hence, run is used by the launchers to execute a given instance of a protocol.
   Note that run calls execution counter that generates a unique execution identifier.
let run f time rand print input events =
   let execution id = execution counter () in
   let container =
      { time = time
      ; rand = rand
      ; print = print
      ; args = ()
      ; execution = execution id }
   in
      (∗ Feed the input events to the event function: ∗)
   let arr feed inputs = constant input events in
   let f = mconcat arr feed inputs >>> f in
      (∗ And execute it: ∗)
   let outputs = f .arrow container in
      (∗ And retrieve the results in the containers: ∗)
      List.map ( fun c → c.args ) outputs
28   CHAPTER 1. MODULE EVENT FUNCTION
       Part II

The Network Launcher




          29
Chapter 2

Module Signatures

When we want to build a Network launcher, we have to instantiate it with modules satisfying the following
signatures. In other words, the Network launcher is a functor on these signatures.
    These signatures deals with :

      • the User interface
      • the Network interface
      • the Timer interface




2.1       User Signature:
module type USER =
sig
  Type definitions:
  type user feedback
  type user action
  Pretty-printers:
  val print user feedback : Format.formatter → user feedback → unit
  val print user action : Format.formatter → user action → unit
  User interface:
 val user interface : ( ( [> ‘User in of user feedback ] Event.channel ) × ( user action Event.channel ) ) →
unit
end




2.2       Network Signature:


                                                   31
32                                                              CHAPTER 2. MODULE SIGNATURES

2.2.1       User-defined Network types
module type NETWORK TYPES =
sig
     Type definitions:
     type message
     Pretty-printers:
     val print message : Format.formatter → message → unit
     Model-Checking helper:
     val signature of message : message → string
     Marshaling functions:
  val to string message : message → string
  val from string message : string → message
end



2.2.2       Generic Network Interface
module type NETWORK =
sig
  Import the user-defined types
  include (NETWORK TYPES )
  transport defines the available transport modes
  type transport =
    | TCP
    | UDP
  net feedback defines the events that the network interface can send to the arrow
  type net feedback =
    | TCP in of Unix .sockaddr × message
         (∗ Received a string on TCP from the sockaddr ∗)
    | UDP in of Unix .sockaddr × message
         (∗ Received a string on UDP from the sockaddr ∗)
    | Listening on of int × transport
         (∗ Confirm that a server is listening on a port for transport ∗)
    | Listening failed of int × transport
         (∗ Signal that the request to open a server on a port for transport has failed ∗)
    | Connection closed of int × transport
         (∗ Signal that the server on the given port, for the given transport is closed ∗)
    | Sent of Unix .sockaddr × transport × message
         (∗ Signal that the data, on transport, for the sockaddr has been sent. Note that we send back the
message. ∗)
    | Send failed of Unix .sockaddr × transport × message
         (∗ Signal that the data, on transport, for the sockaddr has not been sent. Note that we send back
the message ∗)
2.3. TIMER SIGNATURE                                                                                  33

  net action defines the commands which can be interpreted by the network interface.

  type net action =
    | Listen on of int × transport
         (∗ Request to listen on the given port, for the given transport ∗)
    | Close connection of int × transport
         (∗ Request to close the connection on the given port, for the given transport ∗)
    | Send of Unix .sockaddr × transport × message
         (∗ Request to send the given string, on the given transport to the given sockaddr ∗)
    | Network do nothing
         (∗ Request to do nothing. Nice. ∗)

  Pretty-printers:

  val print net feedback : Format.formatter → net feedback → unit
  val print net action : Format.formatter → net action → unit

  Network Interface:

 val network interface : [> ‘Network in of net feedback ] Event.channel × net action Event.channel →
unit

end




2.3     Timer Signature
Most of the time, the user want to be able to define its own timer events while not having to re-implement
the mechanisms to trigger timers and so on.
   So, what we do is that the user has to provide a module satisfying TIMER TYPES and instantiate the
module Timer (see ./timer/timer.ml) with it.
   Once instantiated, the Timer module satisfy the type signature TIMER.



2.3.1    User-defined Timer types

module type TIMER TYPES =
sig

  Type definitions:

  type timers

  Pretty-printers:

  val print timers : Format.formatter → timers → unit
  val signature of command : timers → string

end
34                                                              CHAPTER 2. MODULE SIGNATURES

2.3.2       Generic Timer Interface

module type TIMER =
sig
  Import the user-defined types
  include (TIMER TYPES )
  Type definitions:
  type timer type =
    | Periodic (∗ Will be raised every t period ∗)
    | Unique (∗ Will be raised once, in t ∗)
  timer defines the complete structure of a timer
  type timer =
       { delay : float (∗ the delay between now and when the timer must trigger ∗)
       ; timer type : timer type (∗ the periodicity of the timer ∗)
       ; command : timers } (∗ the command triggered by the timer ∗)
     timer feedback defines the commands that the Timer can send to the arrow
  type timer feedback =
    | Timeout of timer
    | Timer up of timer
    | Timer killed of timer
     timer action defines the commands that can be sent by the arrow to the Timer
     type timer action =
       | Launch timer of timer
       | Kill timer of timer
       | Timer do nothing
  Pretty-printers:
  val print timer feedback : Format.formatter → timer feedback → unit
  val print timer action : Format.formatter → timer action → unit
     Timer interface:
 val timer interface : [> ‘Timer in of timer feedback ] Event.channel × timer action Event.channel →
unit
end
Chapter 3

Module Network interface types

open Net general
module NetworkInterfaceTypes ( NetworkTypes : Signatures.NETWORK TYPES ) =
struct
  include ( NetworkTypes )
  transport defines the available transport modes
  type transport =
    | TCP
    | UDP




3.1     Type definition
  net feedback defines the events that the network interface can send to the arrow
  type net feedback =
    | TCP in of Unix .sockaddr × NetworkTypes.message
         (∗ Received a string on TCP from the sockaddr ∗)
    | UDP in of Unix .sockaddr × NetworkTypes.message
         (∗ Received a string on UDP from the sockaddr ∗)
    | Listening on of int × transport
         (∗ Confirm that a server is listening on a port for transport ∗)
    | Listening failed of int × transport
         (∗ Signal that the request to open a server on a port for transport has failed ∗)
    | Connection closed of int × transport
         (∗ Signal that the server on the given port, for the given transport is closed ∗)
    | Sent of Unix .sockaddr × transport × NetworkTypes.message
         (∗ Signal that the data, on transport, for the sockaddr has been sent. Note that we send back the
message. ∗)
    | Send failed of Unix .sockaddr × transport × NetworkTypes.message
         (∗ Signal that the data, on transport, for the sockaddr has not been sent. Note that we send back
the message ∗)
  net action defines the commands which can be interpreted by the network interface.

                                                   35
36                                         CHAPTER 3. MODULE NETWORK INTERFACE TYPES

 type net action =
   | Listen on of int × transport
        (∗ Request to listen on the given port, for the given transport ∗)
   | Close connection of int × transport
        (∗ Request to close the connection on the given port, for the given transport ∗)
   | Send of Unix .sockaddr × transport × NetworkTypes.message
        (∗ Request to send the given string, on the given transport to the given sockaddr ∗)
   | Network do nothing
        (∗ Request to do nothing. Nice. ∗)



3.2    Signature
  let signature of transport transport =
     match transport with
        | TCP → "tcp"
        | UDP → "udp"
 let signature feedback net feedback =
    match net feedback with
       | TCP in ( addr , data ) →
           "tcp in ["
           ˆ (signature of addr addr )
           ˆ ","
           ˆ (NetworkTypes.signature of message data)
           ˆ "]"
       | UDP in ( addr , data ) →
           "udp in ["
           ˆ (signature of addr addr )
           ˆ ","
           ˆ (NetworkTypes.signature of message data)
           ˆ "]"
       | Listening on ( port , transport ) →
           "listening on ["
           ˆ (string of int port)
           ˆ ","
           ˆ (signature of transport transport)
           ˆ "]"
       | Listening failed ( port , transport ) →
           "listening failed ["
           ˆ (string of int port)
           ˆ ","
           ˆ (signature of transport transport)
           ˆ "]"
       | Connection closed ( port , transport ) →
           "connection closed ["
           ˆ (string of int port)
           ˆ ","
           ˆ (signature of transport transport)
3.3. PRETTY-PRINTER                                          37

          ˆ "]"
      | Sent ( addr , transport , data ) →
          "sent ["
          ˆ (signature of addr addr )
          ˆ ","
          ˆ (signature of transport transport)
          ˆ ","
          ˆ (NetworkTypes.signature of message data)
          ˆ "]"
      | Send failed ( addr , transport , data ) →
          "send failed ["
          ˆ (signature of addr addr )
          ˆ ","
          ˆ (signature of transport transport)
          ˆ ","
          ˆ (NetworkTypes.signature of message data)
          ˆ "]"




3.3    Pretty-printer
 print transport formater transport mode
 let print transport ppf t =
    match t with
      | TCP → Format.fprintf ppf "TCP"
      | UDP → Format.fprintf ppf "UDP"
 print net feedback formater net feedback
 let print net feedback ppf feedback =
    match feedback with
      | TCP in (addr , data ) →
           Format.fprintf ppf "@[TCP in (@[ %a , %a @])@]"
             Net general .print addr addr
             NetworkTypes.print message data
      | UDP in (addr , data ) →
           Format.fprintf ppf "@[UDP in (@[ %a , %a @])@]"
             Net general .print addr addr
             NetworkTypes.print message data
      | Listening on (port , transport) →
           Format.fprintf
             ppf
             "@[Listening on ( %d , %a )@]"
             port
             print transport transport
      | Listening failed ( port , transport ) →
           Format.fprintf
             ppf
             "@[Listening failed ( %d , %a )@]"
38                                      CHAPTER 3. MODULE NETWORK INTERFACE TYPES

           port
           print transport transport
     | Connection closed (port, transport) →
         Format.fprintf
           ppf
           "@[Connection closed (@[ %d , %a @])@]"
           port
           print transport transport
     | Send failed ( addr , transport , data ) →
         Format.fprintf
           ppf
           "@[Send failed (@[ %a , %a , %a @])@]"
           Net general .print addr addr
           print transport transport
           NetworkTypes.print message data
     | Sent (addr , transport , data ) →
         Format.fprintf
           ppf
           "@[Sent (@[ %a , %a , %a @])@]"
           Net general .print addr addr
           print transport transport
           NetworkTypes.print message data
 print net action formater net action
 let print net action ppf action =
    match action with
      | Listen on (port, transport) →
           Format.fprintf
             ppf
             "@[Listen on (@[ %d , %a @])@]"
             port
             print transport transport
      | Close connection (port, transport) →
           Format.fprintf
             ppf
             "@[Close connection ([@ %d , %a @])@]"
             port
             print transport transport
      | Send (addr , transport , data ) →
           Format.fprintf
             ppf
             "@[Send (@[ %a , %a , %a @])@]"
             Net general .print addr addr
             print transport transport
             NetworkTypes.print message data
      | Network do nothing →
           Format.fprintf
             ppf
             "@[%s@]"
             "Network do nothing"
3.3. PRETTY-PRINTER   39

end
40   CHAPTER 3. MODULE NETWORK INTERFACE TYPES
Chapter 4

Module Timer interface types

This functor provides a general interface for any kind of timer.
    To build this functor, you have to pass it a user-defined TIMER TYPES , mainly some timers definition
and their pretty-printing functions. Then, you have everything to run with the Network multiplexer as well
as the Simulator multiplexer.
module TimerInterfaceTypes ( TimerTypes : Signatures.TIMER TYPES ) =
struct



4.1     Module import
  Include the user-defined timers
  include (TimerTypes)



4.2     Type definitions
  timer type defines the periodicity of a timer
  type timer type =
    | Periodic (∗ Will be raised every t period ∗)
    | Unique (∗ Will be raised once, in t ∗)
  timer defines the complete structure of a timer
  type timer =
       { delay : float (∗ the delay between now and when the timer must trigger ∗)
       ; timer type : timer type (∗ the periodicity of the timer ∗)
       ; command : TimerTypes.timers } (∗ the command triggered by the timer ∗)
  timer feedback defines the commands that the Timer can send to the arrow
  type timer feedback =
    | Timeout of timer
    | Timer up of timer
    | Timer killed of timer

                                                     41
42                                                  CHAPTER 4. MODULE TIMER INTERFACE TYPES

  timer action defines the commands that can be sent by the arrow to the Timer
     type timer action =
       | Launch timer of timer
       | Kill timer of timer
       | Timer do nothing




4.3       Pretty-printers
  print timer type formater timer type
     let print timer type ppf t =
        match t with
          | Periodic → Format.fprintf ppf "%s" "Periodic"
          | Unique → Format.fprintf ppf "%s" "Unique"
  print timer formater timer
  let print timer ppf t =
     Format.fprintf
       ppf
       "@[%f@ ,@ %a@ ,@ %a@ @]"
       t.delay
       print timer type t.timer type
       TimerTypes.print timers t.command
     let signature of timer type timer type =
        match timer type with
           | Periodic → "periodic"
           | Unique → "unique"
  let signature of timer t =
     (string of float t.delay) ˆ ":" ˆ
        (signature of timer type t.timer type) ˆ ":" ˆ
        (TimerTypes.signature of command t.command )
     print timer feedback formater timer feedback
     let print timer feedback ppf t =
        match t with
          | Timeout t → Format.fprintf ppf "@[Timeout (@[ %a @])@]" print timer t
          | Timer up t → Format.fprintf ppf "@[Timer up (@[ %a @])@]" print timer t
          | Timer killed t → Format.fprintf ppf "@[Timer killed (@[ %a @])@]" print timer t
  print timer action formater timer action
     let print timer action ppf t =
        match t with
          | Launch timer t → Format.fprintf ppf "@[Launch timer (@[ %a @])@]" print timer t
          | Kill timer t → Format.fprintf ppf "@[Kill timer (@[ %a @])@]" print timer t
          | Timer do nothing → Format.fprintf ppf "@[%s@]" "Timer do nothing"
end
Chapter 5

Module Network hashtbl

Hash table over pairs of port and transport mode. It is used to maintain the set of currently opened servers.
module NetworkHashTbl ( NetworkTypes : Signatures.NETWORK TYPES ) =
struct
  module NetworkInterfaceTypes = Network interface types.NetworkInterfaceTypes ( NetworkTypes )
  open NetworkInterfaceTypes
  module HashThreadF =
  struct
     type t = int × transport
     let equal = (=)
     let hash = Hashtbl .hash
  end
  module HashThread = Hashtbl .Make ( HashThreadF )
  Hash table over pairs of socket address and transport mode. It is used to maintain the set of open
connections.
  module HashFdF =
  struct
     type t = Unix .sockaddr × transport
     let equal = (=)
     let hash = Hashtbl .hash
  end
  module HashFd = Hashtbl .Make ( HashFdF )
end




                                                     43
44   CHAPTER 5. MODULE NETWORK HASHTBL
Chapter 6

Module Network interface

open Net general
open Udp
open Tcp
module NetworkInterface
   (NetworkTypes : Signatures.NETWORK TYPES )
   =
struct
  module NetworkInterfaceTypes = Network interface types.NetworkInterfaceTypes ( NetworkTypes )
  open NetworkInterfaceTypes
  module NetworkHashTbl = Network hashtbl .NetworkHashTbl ( NetworkTypes )
  open NetworkHashTbl
  This code provides an implementation of the Network Interface.
   This is mostly imperative-style programming. Close your eyes if you don’t want to see horrors.
   Good Luck.



6.1     Global structures
  servers is a mutable Hash table associating a pair ( port number, transport mode ) to a reference to a
boolean, named signal .
    To turn off a server, we have to get this reference and turn it to False. Sooner or later, the thread will
exit and die.
    There is no bound on the time between signal := false and the end of the thread. Nonetheless, I have
ensured (hopefully) that once !signal = false, no actions are sent.
  let servers = ( HashThread .create 10 : (bool ref ) HashThread .t )
  connections is a mutable Hash table associating a pair ( socket address , transport mode ) to a connected
file descriptor, corresponding to the given socket address and transport mode.
  let connections = ( HashFd .create 10 : Unix .file descr HashFd .t )
  host corresponds to the IP address of the machine.
   We failed to find a better way than this hack which consumes the first argument of the command line as
our own IP address.

                                                     45
46                                                       CHAPTER 6. MODULE NETWORK INTERFACE

     let host =
        try
           Unix .inet addr of string Sys.argv .(1)
        with
           |   →
               failwith "Opis: first command line argument must be a valid IP address"
  max udp packet size defines the maximum size of a UDP packet.
   Hopefully, this will always work. I need to check that.
  let max udp packet size = 64000




6.2        Utilities
  non blocking send multiplexer channel to multiplexer event sends the event to the multiplexer.
   The non blocking effect is realized by creating a thread containing the code which send the event.
     let non blocking send multiplexer channel multiplexer data =
        ignore (Thread .create (fun () → Event.sync ( Event.send channel multiplexer (‘Network in ( data ) ) )) ())
  create connection connection given a connection, i.e. a server, this creates a thread running this server
controlled by a signal and returns the signal reference.
     let create connection connection =
        let signal = ref true in
           ignore (Thread .create connection signal );
           signal




6.3        Connections
  read tcp ( channel to multiplexer , file descriptor , peer address, signal reference ) reads the file de-
scriptor of a TCP connection and sends the result to the multiplexer.
    Stop and cancel the readings if !signal reference = true
     let read tcp ( channel multiplexer , fd , client addr , signal ) =
        while ( !signal ) do
           let buffer size = 4096 in
           let buffer = String.create buffer size in
           let read acc =
              match Unix .read fd buffer 0 buffer size with
                 | 0 → acc
                 | n →
                       acc ˆ (String.sub buffer 0 n )
           in
           let received = read "" in
              if ( ( received = "" ) ∧ !signal ) then
                 let received = from string message received in
                    non blocking send multiplexer channel multiplexer (TCP in ( client addr , received ) );
        done
6.3. CONNECTIONS                                                                                         47

  server ( channel to multiplexer , port, transport mode ) signal reference creates a server on the given
port, using the given transport mode.
   This function is executed into a thread, the signal reference value is used to emulate the killing of the
thread.
   This code could be split in two part : server udp and server tcp.

  let server ( channel multiplexer , port , transport ) signal =
     begin
       match transport with
          | UDP →
              (∗ Open an UDP server ∗)

             Create a socket and a buffer

             let socket = open udp socket () in
             let addr = Unix .ADDR INET ( host , port ) in
             let buff = String.create max udp packet size in
                begin
                  try
                     (∗ Bind the socket ∗)
                     Unix .setsockopt socket Unix .SO REUSEADDR true;
                     Unix .bind socket addr
                  with
                     | Unix .Unix error ( err , fct , param ) →
                         (∗ If error, print it and sends the error message to the arrow ∗)
                         Printf .printf "Error : %s with parameters [ %s ] failed with error : %s\n" fct param (U
                         signal := false;
                         non blocking send multiplexer channel multiplexer (Listening failed ( port , transport ))
                end;

                While the thread must not die

                while ( !signal ) do

                  Block until receiving data

                  let nb char , requester = Unix .recvfrom socket buff 0 max udp packet size [ ] in
                  let data = String.sub buff 0 nb char in
                     (∗ We are not to be dead ∗)
                     if ( !signal ) then
                        (∗ Sends the event to multiplexer ∗)
                        let data = from string message data in
                           non blocking send multiplexer channel multiplexer (UDP in ( requester , data ) )
                done

         | TCP →
             (∗ Open a TCP server ∗)

             Create a socket

             let socket = open tcp socket () in
             let addr = Unix .ADDR INET ( host , port ) in
48                                                     CHAPTER 6. MODULE NETWORK INTERFACE

               begin
                 try
                    (∗ Bind the socket and listen ∗)
                    Unix .bind socket addr ;
                    Unix .listen socket 100;
                 with
                    | Unix .Unix error (err , fct , param ) →
                        (∗ If error, print it and sends the error message to the arrow ∗)
                        Printf .printf "Error : %s with parameters [ %s ] failed with error : %s\n" fct param (U
                        signal := false;
                        non blocking send multiplexer channel multiplexer (Listening failed ( port , transport ))
               end;
               While the thread must not die
               while ( !signal ) do
                 (∗ Block until we accept a connection ∗)
                 let fd , client addr = Unix .accept socket in
                    (∗ Add the file descriptor to the set of open connections ∗)
                    HashFd .add connections ( client addr , TCP ) fd ;
                      Launch a dedicated server for this connection, in an other thread
                      ignore( Thread .create read tcp (channel multiplexer , fd , client addr , signal ) );
               done
     end




6.4        Interface definition
  network interface ( channel to multiplexer , channel to interface ) gets reactions coming out of the
arrow and executes them.
  let network interface ( channel multiplexer , channel net ) =
     (∗ Always do ∗)
     while true do
       (∗ Get a reaction : ∗)
       let action = Event.sync ( Event.receive ( channel net ) ) in
          begin
             match action with
               | Listen on ( port , transport ) →
                   (∗ The arrow want to listen on port and transport ∗)
                 Create the connection, get a signal reference
                 let t = create connection (server ( channel multiplexer , port , transport )) in
                    if ( !t = false ) then
                       (∗ Something wrong happened, the reason has been sent : do nothing ∗)
                       ()
                    else
                       begin
                          (∗ Save it and signal that this worked ∗)
6.4. INTERFACE DEFINITION                                                                                49

                        HashThread .add servers ( port , transport ) t;
                        non blocking send multiplexer channel multiplexer (Listening on ( port , transport ) )
                      end
              | Close connection ( port , transport ) →
                  (∗ The arrow want that we close the connection on port and transport ∗)
                   begin
                     try
                        let t = HashThread .find servers ( port , transport ) in
                           t := false;
                     with
                        | Not found → ()
                   end;
                   Confirm that it has been deleted
                  non blocking send multiplexer channel multiplexer (Connection closed ( port , transport ) )
              | Send ( address , transport , data ) →
                  (∗ The arrow want to send the data, at the address, using the transport mode ∗)
                    begin
                       match transport with
                         | UDP →
                             (∗ Send it over UDP : ∗)
                              Open the UDP socket
                             let socket = open udp socket () in
                                (∗ Send ∗)
                             let data = to string message data in
                                ignore (Unix .sendto socket data 0 (String.length data) [ ] address);
                                (∗ And don’t forget to close the socket ∗)
                                Unix .close socket;
                         | TCP →
                             (∗ Send it over TCP : ∗)
                              begin
                                try
                                   let fd = HashFd .find connections ( address , transport ) in
                                      (∗ We have found an open connection to this address, using this trans-
port, write on it ∗)
                                     match write fd (to string message data) with
                                      | None →
                                           (∗ It has failed : ∗)
                                            Remove the file descriptor and open a new connection :
                                           HashFd .remove connections ( address , transport );
                                           raise Not found ;
                                       | Some () →
                                           (∗ Perfect, this succeeds ∗)
                                           non blocking send multiplexer channel multiplexer (Sent ( address , transport ,
                                with
                                  | Not found →
                                      (∗ There is no existing connection or it raised an error : ∗)
50                                                    CHAPTER 6. MODULE NETWORK INTERFACE

                                        Open a TCP socket
                                        let socket = open tcp socket () in
                                          Connect and add the connection to the others :
                                          Unix .connect socket address;
                                          HashFd .add connections ( address , transport ) socket;
                                          Send the data :
                                          match write socket (to string message data) with
                                           | None →
                                                (∗ It has definitely failed ∗)
                                                HashFd .remove connections ( address , transport );
                                                non blocking send multiplexer channel multiplexer (Send failed ( address ,
                                           | Some () →
                                                (∗ Perfect, this succeeds ∗)
                                                non blocking send multiplexer channel multiplexer (Sent ( address , transpo
                                 end
                         end
                   | Network do nothing → ()
             end
      done
end
Chapter 7

Module Network timer

The Timer functor is used to build the Timer Interface for the Network Multiplexer.
   It is built using a user-defined module TIMER TYPES that contains her timer events and the associated
pretty-printing functions.
module Timer ( TimerTypes : Signatures.TIMER TYPES ) =
struct




7.1     Modules
  Build the Interface types from the generic Functor
  module TimerInterfaceTypes = Timer interface types.TimerInterfaceTypes(TimerTypes)
  include (TimerInterfaceTypes)
  Define a hash-table over timers. It is used to register the currently running timers.
   It associates a timer to a boolean reference. Putting the referenced value to False turns down the timer.
Then, it should never raise again. Nonetheless, there is no guarantee that the associated thread will be killed
soon.
  module HashTimersF =
  struct
     type t = timer
     let equal = (=)
     let hash = Hashtbl .hash
  end
  module HashTimers = Hashtbl .Make ( HashTimersF )




7.2     Global state
  timers is the hash table of currently running timers
  let timers = HashTimers.create 10



                                                      51
52                                                            CHAPTER 7. MODULE NETWORK TIMER

7.3        Utilities
  send multiplexer channel to multiplexer data blocks until the data is sync’ed by the multiplexer.
     let send multiplexer channel multiplexer data =
        Event.sync ( Event.send channel multiplexer (‘Timer in ( data ) ) )
  non blocking send multiplexer channel to multiplexer data will, in the background, send the given data
to the multiplexer.
    This is achieved by creating a dedicated thread.
     let non blocking send multiplexer channel multiplexer data =
          ignore (Thread .create (fun () → Event.sync ( Event.send channel multiplexer (‘Timer in ( data ) ) )) ())
  unique timer channel to multiplexer delay command signal reference creates a timer which will be raised
once in time seconds, if and only if !signal is true when the timer is triggered.
  let unique timer channel multiplexer time command signal =
     ignore ( Thread .select [ ] [ ] [ ] time );
     if !signal then
        send multiplexer channel multiplexer (Timeout command )
  periodic timer channel to multiplexer delay command signal creates a periodic timer that will raise a
Timeout message every delay seconds, unless !signal is false.
   It will stop once !signal is false.
  let periodic timer channel multiplexer time command signal =
     while !signal do
       ignore ( Thread .select [ ] [ ] [ ] time );
       if (!signal ) then
          non blocking send multiplexer channel multiplexer (Timeout command )
     done
  create timer timer creates a signal value and launch the given timer in a separate thread, with the signal.
   It returns the signal reference, such that we can kill the timer .
  let create timer timer =
     let signal = ref true in
        ignore( Thread .create timer signal );
        signal



7.4        Timer Interface
  timer interface ( channel to multiplexer , channel to timer ) gets its command from the channel to multiplexer
and outputs its reaction to channel to multiplexer .
    Its goal is, mainly, to set up timers and signal timed out events
     let timer interface ( channel multiplexer , channel timer ) =
        (∗ Always ∗)
        while true do
           (∗ Get a command from the Arrow ∗)
           match Event.sync ( Event.receive ( channel timer ) ) with
             | Launch timer timer →
                  (∗ Launch a new timer ∗)
7.4. TIMER INTERFACE                                                                                53

                 Depending on the type, get the correct building function
                 let timer clock =
                    match timer .timer type with
                       | Unique → unique timer
                       | Periodic → periodic timer
                 in
                    (∗ Create the timer ∗)
                 let t = create timer (timer clock channel multiplexer timer .delay timer ) in
                   Register it and signal that things are done
                    HashTimers.add timers timer t;
                    non blocking send multiplexer channel multiplexer (Timer up timer )
             | Kill timer timer →
                 (∗ Stop a timer ∗)
                 begin
                    try
                       (∗ Find it ∗)
                       let t = HashTimers.find timers timer in
                          (∗ Stop it and signal that things are done ∗)
                          t := false;
                          non blocking send multiplexer channel multiplexer (Timer killed timer )
                    with
                       | Not found →
                            (∗ There was no such timer ∗)
                            ()
                 end
             | Timer do nothing → ()
      done
end
54   CHAPTER 7. MODULE NETWORK TIMER
Chapter 8

Module Network launcher

Network Multiplexer
Alias the Event Function module to a shorter name :
module EF = Event function
The Multiplexer Functor takes : - User types (events) and pretty-printing functions - Network interface
(events + routines + pretty-printing) - Timer interface (events + routines + pretty-printing), itself built
from a functor. See timer /timer .ml .
module Launcher
   ( User : Signatures.USER )
   ( Timer : Signatures.TIMER )
   ( NetworkTypes : Signatures.NETWORK TYPES )
   =
struct
  module Network =
  struct
    module NetworkInterface = Network interface.NetworkInterface ( NetworkTypes )
    include NetworkInterface
    include NetworkInterface.NetworkInterfaceTypes
  end




8.1     Type definitions
  The multiplexer input is a polymorphic variant type merging all kind of events send from the interface,i.e.
Network, User and Timer, and relayed to the arrow.
  type multiplexer input =
       [
       | ‘Network in of Network .net feedback
       | ‘User in of User .user feedback
       | ‘Timer in of Timer .timer feedback
       ]

                                                     55
56                                                    CHAPTER 8. MODULE NETWORK LAUNCHER

     The multiplexer output merges all possible output of arrows under one type.
      We consider the Network, User and Timer outputs as well as Do nothing ( a NOP ).

     type multiplexer output =
       | Network out of Network .net action
       | User out of User .user action
       | Timer out of Timer .timer action
       | Do nothing




8.2       Pretty-printers
  string of multiplexer in formater multiplexer input pretty-prints an input. Helpful for debug.

  let string of multiplexer in ppf input =
     match input with
        | ‘Network in net → Format.fprintf ppf "Network in: %a" Network .print net feedback net
        | ‘User in user → Format.fprintf ppf "User in: %a" User .print user feedback user
        | ‘Timer in timer → Format.fprintf ppf "Timer in: %a" Timer .print timer feedback timer

  string of multiplexer out formater multiplexer output pretty-prints an output. Helpful for debug.

     let string of multiplexer out ppf output =
        match output with
           | Network out net → Format.fprintf ppf "Network out: %a" Network .print net action net
           | User out user → Format.fprintf ppf "User out: %a" User .print user action user
           | Timer out timer → Format.fprintf ppf "Timer out: %a" Timer .print timer action timer
           | Do nothing → Format.fprintf ppf "Do nothing"




8.3       Communication with Interfaces
  The architecture of the Network multiplexer relies on threads: User, Timer and Network interfaces are
launched into threads.
    To communicate with them, we have : - a dedicated channel channel user , channel timer and channel net
to send the output of the arrow - a shared channel channel multiplexer to receive the inputs of the arrow

  let   channel   multiplexer = ( Event.new channel () : multiplexer input Event.channel )
  let   channel   net = ( Event.new channel () : Network .net action Event.channel )
  let   channel   user = ( Event.new channel () : User .user action Event.channel )
  let   channel   timer = ( Event.new channel () : Timer .timer action Event.channel )

  treat output command from arrow dispatch an output of the arrow to an action on the right Interface.
8.3. COMMUNICATION WITH INTERFACES                                                                           57

  let treat output command =
     match command with
        | Network out net action →
            Event.sync ( Event.send channel net net action )
        | User out user action →
            Event.sync ( Event.send channel user user action )
        | Timer out timer action →
            Event.sync ( Event.send channel timer timer action )
        | Do nothing → ()
  poll channel accumulator tries to get the maximum number of pending events by polling, if no event is
available, block until something is received.
  let rec poll channel acc =
     match Event.poll ( Event.receive channel ) with
        | None →
            begin
               match acc with
                 | [] →
                      [ Event.sync ( Event.receive channel ) ]
                 |    →
                      List.rev acc
            end
        | Some v → poll channel (v :: acc)
  multiplexer arrow executes the given arrow
  let launcher arrow =
     (∗ First, launch all interfaces ∗)
     ignore ( Thread .create Network .network interface ( channel multiplexer , channel net ) );
     ignore ( Thread .create User .user interface ( channel multiplexer , channel user ) );
     ignore ( Thread .create Timer .timer interface ( channel multiplexer , channel timer ) );
    Initialize the random number generator
    Random.self init ();
    Execution loop
    let rec run v =
       (∗ Process the input through the arrow ∗)
       let v =
          EF .run
             arrow
             (Unix .gettimeofday ())
             Random.float
             (fun s → print string ("[" ˆ (string of float (Unix .gettimeofday ()) ) ˆ "] " ˆ Sys.argv .(1) ˆ " : " ˆ s) )
             v
       in
          (∗ Treat all outputs : ∗)
          List.iter treat output v ;
          (∗ Get the new inputs from interfaces : ∗)
          let input = poll channel multiplexer [ ] in
             (∗ And go on ∗)
58                                                        CHAPTER 8. MODULE NETWORK LAUNCHER

               run input
      in
           (∗ Get a first event and run the arrow on it : ∗)
           run [ (Event.sync ( Event.receive ( channel multiplexer ) ) ) ]
end
        Part III

The Simulator Launcher




           59
Chapter 9

Module Simulation signatures

Here, we define the module signatures used for the Simulator Multiplexer.
   This concerns :

   • the User : change method user interface, add a init method

   • the Timer : use of a priority queue to manage timed events, plus some method to get them

    Moreover, we have defined a signature Simulation properties, which might be extended in a near future,
used to define the property of a simulation.
    Until now, the developper has to provide it but we could write a simple module that reads a configuration
file and would be usable with every project.



9.1     Simulated User Signature

module type SIMULATION USER =
sig




9.1.1    Type definitions

  type user feedback
  type user action




9.1.2    Pretty-printers

  val print user feedback : Format.formatter → user feedback → unit
  val print user action : Format.formatter → user action → unit



                                                    61
62                                               CHAPTER 9. MODULE SIMULATION SIGNATURES

9.1.3      User interface
  init address is called to setup the node when the simulation starts. It can be seen as a simulated way to
pass command line arguments.
  val init : int → user feedback
  user interface time address user action maybe user feedback is called when the arrow request a user
action. The simulator address of the node and the simulated time are passed as parameters.
    The user interface can provide a feed-back. Or not. Using the option type.
  val user interface : int → int → user action → user feedback option
end




9.2       Simulated Timer Signature

module type SIMULATION TIMER =
sig
  As explained in signatures.ml , we use user-defined timers and import them.
     include (Signatures.TIMER TYPES )




9.2.1      Inner module
  We use a Timer queue, which is essentially a strange priority queue. See ./utils/priority queue.ml .
  module TimersQueue :
  sig
     type t
     type queue
     val create : unit → queue
     val insert : float → t → queue → queue
     val remove : t → queue → queue
     val peek until : float → queue → t list × queue
     val size queue : queue → int
     val print queue : Format.formatter → queue → unit
  end




9.2.2      Type definitions

  type timer feedback
  type timer action
9.3. SIMULATION PROPERTIES                                                                             63

9.2.3    Pretty-printers

  val print timer feedback : Format.formatter → timer feedback → unit
  val print timer action : Format.formatter → timer action → unit



9.2.4    Timer interface
  timed out current time timers queue returns a pair containing the list of all expired timers and the new
timers queue
  val timed out : int → TimersQueue.queue → timer feedback list × TimersQueue.queue
  timer interface time address timer action timers queue adds the given timer action to the timers queue.
    It returns a list, possibly empty, of timer feedback ( thus getting the timed out events) and the new
timers queue
  val timer interface : int → int → timer action → TimersQueue.queue → timer feedback list × TimersQueue.queue
end




9.3     Simulation Properties
module type SIMULATION PROPERTIES =
sig
  val network size : int
  end time defines the number of cycles of the simulator
  val end time : int
  if slow is true, we sleep 1s. between each host
  val slow : bool
  latency node1 node2 defines the latency between two hosts, in seconds
  val latency : int → int → float
end
64   CHAPTER 9. MODULE SIMULATION SIGNATURES
Chapter 10

Module Simulator network

This module defines a network input queue, for simulating the latency over the network.
   It uses a Priority Queue. See ./utils/priority queue.ml .
module SimulatorNetwork
   ( NetworkTypes : Signatures.NETWORK TYPES )
   =
struct
  module NetworkInterfaceTypes = Network interface types.NetworkInterfaceTypes ( NetworkTypes )
  Define a packet
  type α packet =
       {
         delay : float ; (∗* the time this packet will take to go from the sender to the destination ∗)
         data : NetworkInterfaceTypes.net feedback (∗* the payload ∗)
       }
  Define an order on packets
  module OrderOnPackets =
  struct
     type t = string packet
     let compare x t = compare x t.delay
     let get delay t = t.delay
     let print ppf t = NetworkInterfaceTypes.print net feedback ppf t.data
  end
  Build the network queue out of a priority queue
  module NetworkQueue = Priority queue.Make ( OrderOnPackets )
end




                                                    65
66   CHAPTER 10. MODULE SIMULATOR NETWORK
Chapter 11

Module Simulator timer

module Timer ( TimerTypes : Signatures.TIMER TYPES ) =
struct




11.1      Module imports
  Include the user-defined timers
  module TimerInterfaceTypes = Timer interface types.TimerInterfaceTypes( TimerTypes )
  include (TimerInterfaceTypes)
  Build a priority queue for timers
  module OrderOnTimes =
  struct
     type t = timer
     let compare x t = compare x t.delay
     let get delay t = t.delay
     let print ppf t = print timer ppf t
  end
  module TimersQueue = Priority queue.Make ( OrderOnTimes )




11.2      Utility
  refeed periodic time timers queue list of timers extracts the Periodic timers of list of timers and re-
inserts them in the priority queue
  let rec refeed periodic time timing queue timers =
     match timers with
        | [ ] → timing queue
        | ( { timer type = Periodic } as timer ) :: timers →
              refeed periodic time (TimersQueue.insert time timer timing queue) timers
        |     :: timers →
              refeed periodic time timing queue timers

                                                   67
68                                                     CHAPTER 11. MODULE SIMULATOR TIMER




11.3     Timer Interface
  timed out time timer queue gets all timers which have expired and the new timers queue.
    When Periodic timers are extracted, we re-feed them to the timers queue.
  let timed out time timing queue =
     let time = float of int time in
     let feedbacks , timing queue = TimersQueue.peek until time timing queue in
        ( List.map (fun x → Timeout x ) feedbacks ) , (refeed periodic time timing queue feedbacks)
  timer interface address current time timer action timers queue applies the timer action and replies
with pending events
  let timer interface address time timer action timing queue =
     let timer interface int () =
        match timer action with
           | Launch timer timer →
               Some (Timer up timer ) , (TimersQueue.insert (float of int time) timer timing queue)
           | Kill timer timer →
               Some (Timer killed timer ) , (TimersQueue.remove timer timing queue)
           | Timer do nothing →
               None , timing queue
     in
     let feedback , timing queue = timer interface int () in
     let feedbacks =
        match feedback with
           | None → [ ]
           | Some feedback → [feedback ]
     in
        feedbacks , timing queue
end
Chapter 12

Module Simulator launcher

This module defines the Simulator Multiplexer functor.
module EF = Event function
module Launcher
   (SimulationProperties : Simulation signatures.SIMULATION PROPERTIES )
   ( User : Simulation signatures.SIMULATION USER )
   ( Timer : Simulation signatures.SIMULATION TIMER )
   ( NetworkTypes : Signatures.NETWORK TYPES )
   =
struct
  module NetworkInterfaceTypes = Network interface types.NetworkInterfaceTypes ( NetworkTypes )
  module Network = NetworkInterfaceTypes
  open NetworkInterfaceTypes
  module SimulatorNetwork = Simulator network .SimulatorNetwork ( NetworkTypes )
  open SimulatorNetwork




12.1     Type definitions
  See ./launchers/network /network launcher .ml for an in-depth explanation.
   We need to comply with the same type signature. This code could obviously be factorized.
  type multiplexer input =
       [
       | ‘Network in of Network .net feedback
       | ‘User in of User .user feedback
       | ‘Timer in of Timer .timer feedback
       ]
  type multiplexer output =
    | Network out of Network .net action
    | User out of User .user action
    | Timer out of Timer .timer action
    | Do nothing

                                                  69
70                                                 CHAPTER 12. MODULE SIMULATOR LAUNCHER

     peer defines a standalone peer in the system
  type (α, β) peer =
       {
          process : (α, β) EF .arrow ; (∗ the event function ∗)
          printer : int → string → unit ; (∗ a node-specialized pretty-printer, printer time string ∗)
          address : Unix .inet addr ; (∗ the node IP address ∗)
          mutable pending timer : Timer .timer feedback list ; (∗ pending timer events, they are sent to the
arrow at the next round ∗)
          mutable pending user : User .user feedback list ; (∗ pending user events, they are sent to the
arrow at the next round ∗)
          mutable pending network : NetworkQueue.queue ; (∗ pending network events, those who have
timed out (latency) are sent at the next round ∗)
          mutable listening ports : ( int × Network .transport ) list ; (∗ open ports of the node, emulates
the classical mechanism ∗)
          mutable timer queue : Timer .TimersQueue.queue ; (∗ timers ∗)
       }




12.2        Pretty-printers

     let string of multiplexer in ppf input =
        match input with
           | ‘Network in net → Format.fprintf ppf "@[Network in: %a@]" Network .print net feedback net
           | ‘User in user → Format.fprintf ppf "@[User in: %a@]" User .print user feedback user
           | ‘Timer in timer → Format.fprintf ppf "@[Timer in: %a@]" Timer .print timer feedback timer
     let string of multiplexer out ppf output =
        match output with
           | Network out net → Format.fprintf ppf "@[Network out: %a@]" Network .print net action net
           | User out user → Format.fprintf ppf "@[User out: %a@]" User .print user action user
           | Timer out timer → Format.fprintf ppf "@[Timer out: %a@]" Timer .print timer action timer
           | Do nothing → Format.fprintf ppf "@[%s@]" "Do nothing"




12.3        Utility
  make empty peer arrow node address build a fresh peer running the given arrow , at address node address
     let make empty peer arrow address =
        {
          address = Int to inet.inet addr of int address ;
          printer = (fun time string → Printf .printf "[%d] %d : %s" time address string ) ;
          process = EF .clone arrow arrow ;
          pending timer = [ ] ;
          pending user = [User .init address] ;
          pending network = NetworkQueue.create () ;
          listening ports = [ ] ;
12.3. UTILITY                                                                                                71

         timer queue = Timer .TimersQueue.create () ;
     }
  treat output set of peers current peer address current time arrow output is one big, ugly function that
applies the commands from the arrow.
   After any arrow execution, treat output is called with a list composed of at least Do nothing. Thus,
timers can be collected.
   This could efficiently be cut into smaller functions.
  let treat output peers addr time output =
     let peer = peers.(addr ) in
     let f time = float of int time in
        begin
          match output with
             | Network out network action →
                 (∗ Network command : ∗)
                 begin
                   match network action with
                      | Listen on (port , transport) →
                          (∗ Open a port for the given transport ∗)
                          peer .listening ports ← (port , transport) :: peer .listening ports;
                          peer .pending network ← NetworkQueue.insert f time { delay = 0. ; data = Listening on (port ,
                     | Close connection (port , transport) →
                         (∗ Close the port, for the given transport ∗)
                         peer .listening ports ← List.filter ((=) (port, transport)) peer .listening ports;
                         peer .pending network ← NetworkQueue.insert f time { delay = 0. ; data = Connection closed (
                     | Send ( dest addr , transport , data ) →
                         (∗ Send some data over the network ∗)
                         begin
                           (∗ Compute destination id from the IP address ∗)
                           let dest , port = match dest addr with
                              | Unix .ADDR INET ( dest , port ) →
                                   let , a2 , a3 , a4 = Scanf .sscanf (Unix .string of inet addr dest) "%d.%d.%d.%d" (fun w x
w , x , y, z ) in
                                      a2 + a3 + a4 , port
                                |    → failwith "Simulator : treat output : did not received an Inet address ?!"
                           in
                                try
                                   (∗ If the corresponding port is closed, an exception is raised. See below for
the handler ∗)
                                    ignore(List.find ((=) (port, transport)) peers.(dest).listening ports);
                                    We are here, meaning that the port is open
                                    let peer address = Unix .ADDR INET ( peer .address , port ) in
                                    let packet = match transport with
                                       | TCP →
                                            TCP in ( peer address , data )
                                       | UDP →
                                            UDP in ( peer address , data )
                                    in
72                                          CHAPTER 12. MODULE SIMULATOR LAUNCHER

                            (∗ Put the packet in dest pending network queue with the right latency
∗)
                            peers.(dest).pending network ←
                              NetworkQueue.insert
                              f time
                              {
                                  delay = SimulationProperties.latency addr dest ;
                                  data = packet
                              }
                              peers.(dest).pending network ;
                            (∗ Confirm that we are done ∗)
                            peer .pending network ←
                              NetworkQueue.insert
                              f time
                              {
                                  delay = 0. ;
                                  data = Sent ( dest addr , transport, data )
                              }
                              peer .pending network ;
                     with
                       |      →
                              (∗ The port was closed ∗)
                              begin
                                match transport with
                                   | TCP →
                                       (∗ If its TCP, signal it ∗)
                                       peer .pending network ←
                                          NetworkQueue.insert
                                          f time
                                          {
                                             delay = 0. ;
                                             data = Send failed ( dest addr , transport , data )
                                          }
                                          peer .pending network ;
                                   |   →
                                       (∗ Otherwise, fail silently ∗)
                                       ()
                              end
                end
            | Network do nothing → ()
         end
     | User out user action →
         (∗ User command : ∗)
        Execute it and collect feedbacks
        let feedback = User .user interface addr time user action in
           begin
              match feedback with
                | Some x → peer .pending user ← x :: peer .pending user
                | None → ()
12.4. MULTIPLEXER                                                                                     73

                 end
           | Timer out timer action →
               (∗ Timer command : ∗)
                Execute it and collect timed out events
               let feedbacks , timer queue = Timer .timer interface addr time timer action peer .timer queue in
                  peer .timer queue ← timer queue;
                  peer .pending timer ← feedbacks @ peer .pending timer ;
           | Do nothing →
               (∗ NOP ∗)
               ()
       end;
       (∗ In all cases, collect timed out timers ∗)
       let feedbacks , timer queue = Timer .timed out time peer .timer queue in
          peer .timer queue ← timer queue;
          peer .pending timer ← feedbacks @ peer .pending timer




12.4      Multiplexer
 multiplexer arrow build a network according to the Simulation properties composed of the given arrow .
 let launcher arrow =
   Printf .printf "[] Setup the network... ";
   flush stdout;
   let peers = Array.init SimulationProperties.network size (make empty peer arrow ) in
      Printf .printf "Done.\n";
      flush stdout;
       let rec run time =
          let f time = float of int time in
             for i = 0 to (SimulationProperties.network size − 1) do
                (∗ Get the current peer ∗)
                let peer = peers.(i ) in
             Get its timer feedbacks then clear them :
             let timer feedbacks = List.map (fun x → ‘Timer in x ) peer .pending timer in
                peer .pending timer ← [ ];
                Get its user feedbacks then clear them :
                let user feedbacks = List.map (fun x → ‘User in x ) peer .pending user in
                   peer .pending user ← [ ];
                  Get its network feedbacks then update them :
                  let network feedbacks , remaining pending net = NetworkQueue.peek until f time peer .pending network
                  let network feedbacks = List.map (fun x → ‘Network in x .data) network feedbacks in
                     peer .pending network ← remaining pending net ;
                    Merge all input events
74                                                   CHAPTER 12. MODULE SIMULATOR LAUNCHER

                      let inputs = timer feedbacks @ user feedbacks @ network feedbacks in
                      Run the arrow
                      let outputs = EF .run peer .process (float of int i ) Random.float (peer .printer time) inputs in
                         (∗ Treat each arrow command ∗)
                         List.iter (treat output peers i time) ( Do nothing :: outputs );
             done;
             if (SimulationProperties.slow ) then
                Unix .sleep 1;
             if ( time > SimulationProperties.end time ) then
                failwith "End of simulation";
             Go ahead
             run (time + 1)
      in
           run 0
end
       Part IV

The Debugger Launcher




          75
Chapter 13

Module Debugger signatures

module type DEBUGGER USER =
sig
   type user feedback
   type user action
  val print user feedback : Format.formatter → user feedback → unit
  val print user action : Format.formatter → user action → unit
  val user interface : int → int → user action → user feedback option
  val init : int → user feedback
end
module type DEBUGGER TIMER =
sig
  include (Signatures.TIMER TYPES )
  module TimersQueue :
  sig
     type t
     type queue
     val create : unit → queue
     val insert : float → t → queue → queue
     val remove : t → queue → queue
     val peek until : float → queue → t list × queue
     val size queue : queue → int
     val print queue : Format.formatter → queue → unit
  end
  type timer feedback
  type timer action
  val print timer feedback : Format.formatter → timer feedback → unit
  val print timer action : Format.formatter → timer action → unit
  val timed out : int → TimersQueue.queue → timer feedback list × TimersQueue.queue
  val timer interface : int → int → timer action → TimersQueue.queue → timer feedback list × TimersQueue.queue
end


                                               77
78                                  CHAPTER 13. MODULE DEBUGGER SIGNATURES

module type DEBUGGER PROPERTIES =
sig
  val network size : int
end
Chapter 14

Module Peer

module EF = Event function
module Make
   ( User : Debugger signatures.DEBUGGER USER )
   ( Timer : Debugger signatures.DEBUGGER TIMER )
   ( NetworkTypes : Signatures.NETWORK TYPES )
   =
struct
  module NetworkInterfaceTypes = Network interface types.NetworkInterfaceTypes ( NetworkTypes )
  type (α, β) peer =
       {
         process : (α, β) EF .arrow ;
         printer : int → string → unit ;
         address : Unix .inet addr ;
         pending timer : Timer .timer feedback list ;
         pending user : User .user feedback list ;
         pending network : NetworkInterfaceTypes.net feedback list ;
         listening ports : ( int × NetworkInterfaceTypes.transport ) list ;
         timer queue : Timer .TimersQueue.queue ;
       }
  let make empty peer arrow address =
     {
       address = Int to inet.inet addr of int address ;
       printer = (fun time string → Printf .printf "[%d] %d : %s" time address string ) ;
       process = arrow ;
       pending timer = [ ] ;
       pending user = [User .init address] ;
       pending network = [ ] ;
       listening ports = [ ] ;
       timer queue = Timer .TimersQueue.create () ;
     }
end



                                                    79
80   CHAPTER 14. MODULE PEER
Chapter 15

Module Network map

module IntOrdered =
 struct
    type t = int
    let compare = ( compare : int → int → int )
 end
module NetworkMap = Map.Make ( IntOrdered )




                                              81
82   CHAPTER 15. MODULE NETWORK MAP
Chapter 16

Module Debugger launcher

open Network map
open Cli ast exec
module EF = Event function
module Launcher
   ( SimulationProperties : Debugger signatures.DEBUGGER PROPERTIES )
   ( User : Simulation signatures.SIMULATION USER )
   ( Timer : Simulation signatures.SIMULATION TIMER )
   ( NetworkTypes : Signatures.NETWORK TYPES )
   =
struct
  module Exec = Cli ast exec.Make ( User ) ( Timer ) ( NetworkTypes )
  open Exec
  module Network = Exec.NetworkInterfaceTypes
  open Network
  include Exec
  open PeerDefinition
  let rec get line line str =
     match line with
        | 1 →
            let end line idx = String.index str ’\n’ in
            let line = String.sub str 0 end line idx in
               line
        |   →
            let end line idx = String.index str ’\n’ in
               get line (line − 1) (String.sub str (end line idx + 1) (String.length str − end line idx ))
  let print error str line char =
     let faulty line = get line line str in
        Printf .printf "%s\n" faulty line;
        for i = 0 to (char -1) do
           Printf .printf " ";
        done;
        Printf .printf "^\n"

                                                     83
84                                                   CHAPTER 16. MODULE DEBUGGER LAUNCHER

     let network init no peers arrow =
        let rec net init int peer arrow network =
           if peer = no peers then
              network
           else
              let network = NetworkMap.add peer (make empty peer arrow peer ) network in
                 net init int (peer + 1) arrow network
        in
           net init int 0 arrow NetworkMap.empty
 let launcher arrow =
       Printf .printf "[] Setup the network... ";
       flush stdout;
       let network = network init SimulationProperties.network size arrow in
          Printf .printf "Done.\n";
          flush stdout;
          Printf .printf "Type \"help\" to get general informations.\n";
          Printf .printf "Type \"quit\" to quit the debugger.\n";
          flush stdout;
         let lexbuf = Lexing.from channel stdin in
         let rec run time history network =
            print string "> ";
            flush stdout;
            try
               let command = Cli parser .main Cli lexer .lexer lexbuf in
                  Cli ast printer .print ast Format.str formatter command ;
                  Lexing.flush input lexbuf ;
                    match command with
                      | Cli ast.Quit → exit 0
                      | Cli ast.Eol → run time history network
                      |    →
                           let new time , new history , new network = exec command command time history network in
                              run new time new history new network
            with e →
               begin
                  match e with
                    | Parsing.Parse error →
                         Printf .printf "Parsing error : line %d char %d\n" lexbuf .Lexing.lex curr p.Lexing.pos lnum lexbu
                         print error lexbuf .Lexing.lex buffer lexbuf .Lexing.lex curr p.Lexing.pos lnum lexbuf .Lexing.lex curr
                         flush stdout;
                         Lexing.flush input lexbuf
                    | Failure "lexing: empty token" →
                         Printf .printf "Lexing error : unknown command\n";
                         print error lexbuf .Lexing.lex buffer lexbuf .Lexing.lex curr p.Lexing.pos lnum lexbuf .Lexing.lex curr
                         flush stdout;
                         Lexing.flush input lexbuf
                    |    →
                         raise e
               end;
                                        85

             run time history network
      in
           run 0 [ ] network
end
86   CHAPTER 16. MODULE DEBUGGER LAUNCHER
Chapter 17

Module Cli ast

type peerId = int
type eventType =
  | Pending network
  | Pending timer
  | Pending user
type eventId = eventType × int
type state id = string
type showPeerCommand =
  | All events
  | Net events
  | Timer events
  | User events
  | Registred timers
  | Open ports
  | State of state id
type showCommand =
  | NetworkShow
  | PeerShow of peerId
  | SpecificPeerShow of ( peerId × showPeerCommand )
  | SpecificListPeerShow of ( peerId × ( showPeerCommand list ) )
type eventSelection =
  | AllEvents
  | Event of eventId
  | Events of eventId list
type stepCommand =
  | Network of int
  | PeersStepping of peerId list
  | PeerStepping of ( peerId × eventSelection )
  | TimeStepping of int
type backstepCommand =
  | Back of int


                                                  87
88                                   CHAPTER 17. MODULE CLI AST

type helpShowPeer =
  | AllHelpShowPeer
  | OnNetEvents
  | OnTimerEvents
  | OnUserEvents
  | OnRegistredTimers
  | OnOpenPorts
  | OnState
type helpShow =
  | AllHelpShow
  | HelpShowOnNetwork
  | HelpShowOnPeer of helpShowPeer
type helpStep =
  | AllHelpStep
  | OnNetwork
  | OnPeers
  | OnPeer
  | OnTime
type helpBack =
  | AllHelpBack
  | OnActions
type helpCommand =
  | OnShow of helpShow
  | OnStep of helpStep
  | OnBack of helpBack
  | OnHelp
type command =
  | Show of showCommand
  | Step of stepCommand
  | Backstep of backstepCommand
  | Help of helpCommand
  | Quit
  | Eol
Chapter 18

Module Cli ast printer

open Cli ast
let print command ppf c =
   match c with
     | All events →
          Format.fprintf ppf "@[%s@]" "all"
     | Net events →
          Format.fprintf ppf "@[%s@]" "net events"
     | Timer events →
          Format.fprintf ppf "@[%s@]" "timer events"
     | User events →
          Format.fprintf ppf "@[%s@]" "user events"
     | Registred timers →
          Format.fprintf ppf "@[%s@]" "registred timers"
     | Open ports →
          Format.fprintf ppf "@[%s@]" "open ports"
     | State id →
          Format.fprintf ppf "@[%s %s@]" "state" id
let print list command ppf pl =
   let rec print int ppf pl =
      match pl with
         | [] →
              Format.fprintf ppf "@[%s@]" ""
         | [x ] →
              Format.fprintf ppf "@[%a@]" print command x
         | h :: t →
              Format.fprintf ppf "@[%a ; %a @]" print command h print int t
   in
      Format.fprintf ppf "@[[ %a]@]" print int pl
let print show ppf s =
   match s with
     | NetworkShow →
          Format.fprintf ppf "@[%s@]" "network"
     | PeerShow ( peer ) →
          Format.fprintf ppf "@[peer %d@]" peer

                                                  89
90                                                       CHAPTER 18. MODULE CLI AST PRINTER

     | SpecificPeerShow ( peer , peer command ) →
         Format.fprintf ppf "@[peer %d %a@]" peer print command peer command
     | SpecificListPeerShow ( peer , peer command list ) →
         Format.fprintf ppf "@[peer %d %a@]" peer print list command peer command list

let print int list ppf pl =
   let rec print int ppf pl =
      match pl with
         | [] →
              Format.fprintf ppf "@[%s@]" ""
         | [x ] →
              Format.fprintf ppf "@[%d@]" x
         | h :: t →
              Format.fprintf ppf "@[%d ; %a @]" h print int t
   in
      Format.fprintf ppf "@[[ %a]@]" print int pl

let rec print event selection ppf e =
   match e with
      | AllEvents →
          Format.fprintf ppf "@[%s@]" "all"
      | Event event id →
          Format.fprintf ppf "@[%d@]" (snd event id )
      | Events event id list →
          Format.fprintf ppf "@[%a@]" print int list (List.map snd event id list)

let print step ppf s =
   match s with
     | Network no rounds →
          Format.fprintf ppf "@[network %d rounds@]" no rounds
     | PeersStepping peersList →
          Format.fprintf ppf "@[peers %a@]" print int list peersList
     | PeerStepping ( peer , AllEvents ) →
          Format.fprintf ppf "@[peer %d@]" peer
     | PeerStepping ( peer , event selection ) →
          Format.fprintf ppf "@[peer %d %a@]" peer print event selection event selection
     | TimeStepping ( time ) →
          Format.fprintf ppf "@[time +%d@]" time

let print backstep ppf s =
   match s with
     | Back 0 →
          Format.fprintf ppf "%s" ""
     | Back n →
          Format.fprintf ppf "@[%d actions@]" n

let print help ppf s =
   Format.fprintf ppf "%s" "Help"
                                                                    91

let print ast ppf ast =
   match ast with
     | Show s →
          Format.fprintf   ppf "@[show %a@]" print show s
     | Step s →
          Format.fprintf   ppf "@[step %a@]" print step s
     | Backstep s →
          Format.fprintf   ppf "@[backstep %a@]" print backstep s
     | Help s →
          Format.fprintf   ppf "@[help %a@]" print help s
     | Quit →
          Format.fprintf   ppf "@[%s@]" "Quit"
     | Eol →
          Format.fprintf   ppf "@[%s@]" "\n"
92   CHAPTER 18. MODULE CLI AST PRINTER
Chapter 19

Module Cli ast exec

open Network map
open Cli ast

module EF = Event function

module Make
   ( User : Debugger signatures.DEBUGGER USER )
   ( Timer : Debugger signatures.DEBUGGER TIMER )
   ( NetworkTypes : Signatures.NETWORK TYPES ) =
struct

 module PeerDefinition = Peer .Make ( User ) ( Timer ) ( NetworkTypes )
 open PeerDefinition

 module NetworkInterfaceTypes = Network interface types.NetworkInterfaceTypes ( NetworkTypes )
 open NetworkInterfaceTypes

 type multiplexer input =
      [
      | ‘Network in of NetworkInterfaceTypes.net feedback
      | ‘User in of User .user feedback
      | ‘Timer in of Timer .timer feedback
      ]

 let string of multiplexer in ppf input =
       match input with
         | ‘Network in net → Format.fprintf ppf "@[Network in: %a@]" NetworkInterfaceTypes.print net feedback net
         | ‘User in user → Format.fprintf ppf "@[User in: %a@]" User .print user feedback user
         | ‘Timer in timer → Format.fprintf ppf "@[Timer in: %a@]" Timer .print timer feedback timer

 type multiplexer output =
   | Network out of NetworkInterfaceTypes.net action
   | User out of User .user action
   | Timer out of Timer .timer action
   | Do nothing


                                                 93
94                                                               CHAPTER 19. MODULE CLI AST EXEC

     let string of multiplexer out ppf output =
        match output with
           | Network out net → Format.fprintf ppf "@[Network out: %a@]" NetworkInterfaceTypes.print net action net
           | User out user → Format.fprintf ppf "@[User out: %a@]" User .print user action user
           | Timer out timer → Format.fprintf ppf "@[Timer out: %a@]" Timer .print timer action timer
           | Do nothing → Format.fprintf ppf "@[%s@]" "Do nothing"
 let exec show network time network =
    let print short peer ppf peer   =
       Format.fprintf ppf "@[Peer %d : Up@]@ " peer
    in
    let print short net ppf network =
       NetworkMap.iter (print short peer ppf ) network
    in
       Format.fprintf Format.std formatter
         "@[<v 1>@[Time : %d@]
                      @[Network state :@ @[<v 2>%a@]@]
              @]@."
         time
         print short net network
  let exec show peer time peer =
     let print int block ppf (title, int param) =
        Format.fprintf ppf "@[%s : %d@]@ " title int param
     in
     let print str block ppf (title, str param) =
        Format.fprintf ppf "@[%s : %s@]@ " title str param
     in
     let print peer ppf peer =
        Format.fprintf ppf
          "@[<v 1>%a@ %a@ %a@ %a@ %a@ %a@]@."
          print str block ("ID" , (Unix .string of inet addr peer .address))
          print int block ("No. pending net. events" , (List.length peer .pending network ) )
          print int block ("No. pending timer events" , (List.length peer .pending timer ) )
          print int block ("No. pending user events" , (List.length peer .pending user ) )
          print int block ("No. registred timers" , (Timer .TimersQueue.size queue peer .timer queue ) )
          print int block ("No. open ports" , (List.length peer .listening ports) )
     in
        print peer Format.std formatter peer
     let print list tag ppf (pretty printer , l ) =
        let rec print list int pos ppf l =
           match l with
              | [ ] → ()
              | [x ] →
                    Format.fprintf ppf "(%s%d)@ %a" tag pos pretty printer x
              | h :: t →
                    Format.fprintf ppf
                      "@[(%s%d)@ %a@]@ ; %a"
                      tag
                      pos
                                                                                                     95

               pretty printer h
               (print list int (pos + 1)) t
  in
       Format.fprintf ppf "@[[ %a ]@]" (print list int 0) l
let print untagged list ppf (pretty printer , l ) =
   let rec print list int ppf l =
      match l with
         | [ ] → ()
         | [x ] →
               Format.fprintf ppf "@ %a" pretty printer x
         | h :: t →
               Format.fprintf ppf
                 "%a@ ; %a"
                 pretty printer h
                 print list int t
   in
      Format.fprintf ppf "@[[ %a ]@]" print list int l
let exec show netevents ppf peer =
   let print event ppf event =
      Format.fprintf ppf "@[%a@]" NetworkInterfaceTypes.print net feedback event
   in
      Format.fprintf ppf "@[<v 1>%a@]" (print list "n") (print event , peer .pending network )
let exec show timerevents ppf peer =
   let print event ppf event =
      Format.fprintf ppf "@[%a@]" Timer .print timer feedback event
   in
      Format.fprintf ppf "@[<v 1>%a@]" (print list "t") (print event , peer .pending timer )
let exec show userevents ppf peer =
   let print event ppf event =
      Format.fprintf ppf "@[%a@]" User .print user feedback event
   in
      Format.fprintf ppf "@[<v 1>%a@]" (print list "u") (print event , peer .pending user )
let exec show registredtimers ppf peer =
   Format.fprintf ppf "@[%a@]" Timer .TimersQueue.print queue peer .timer queue
let exec show openports ppf peer =
   let print port ppf port =
      Format.fprintf ppf "@[%d : %a@]" (fst port) NetworkInterfaceTypes.print transport (snd port)
   in
      Format.fprintf ppf "@[<v 1>%a@]" print untagged list ( print port , peer .listening ports )
let exec show allevents peer ppf peer =
   Format.fprintf
     ppf
     "@[<v 1>@[<v 2>Network events : %a@]@ @[<v 2>Timer events : %a@]@ @[<v 2>User events : %a@]@ @
     exec show netevents peer
     exec show timerevents peer
     exec show userevents peer
96                                                             CHAPTER 19. MODULE CLI AST EXEC

      exec show registredtimers peer
      exec show openports peer
  let exec show state state id ppf peer =
     EF .print state peer .process ppf state id
 let exec show specific peer time peer command =
    let ( printer , command str ) =
       match command with
          | All events → ( exec show allevents peer , "All events" )
          | Net events → ( exec show netevents , "Network events" )
          | User events → ( exec show userevents , "User events" )
          | Timer events → ( exec show timerevents , "Timer events" )
          | Registred timers → ( exec show registredtimers , "Registred timers" )
          | Open ports → ( exec show openports , "Open ports" )
          | State s → ( exec show state s , "State" )
    in
       Format.fprintf Format.std formatter "@[<v 1>%s :@ @[<v 2>%a@]@]@." command str printer peer
 let exec show command time history network =
    begin
       match command with
         | NetworkShow → exec show network time network
         | PeerShow peer → exec show peer time (NetworkMap.find peer network )
         | SpecificPeerShow ( peer , command ) → exec show specific peer time (NetworkMap.find peer network ) command
         | SpecificListPeerShow ( peer , commands ) →
             List.iter (exec show specific peer time (NetworkMap.find peer network )) commands
    end;
    ( time , history , network )
 let treat network output network peer addr time output =
     let peer = NetworkMap.find peer addr network in
         match output with
            | Listen on ( port , transport ) →
                  let peer = { peer with listening ports = ( port , transport ) :: peer .listening ports } in
                  let peer = { peer with pending network = ( Listening on ( port , transport ) ) :: peer .pending network } in
                     NetworkMap.add peer addr peer network
            | Close connection ( port , transport ) →
                  let peer = { peer with listening ports = List.filter ((=) (port, transport)) peer .listening ports } in
                  let peer = { peer with pending network = ( Connection closed ( port , transport ) ) :: peer .pending network }
                     NetworkMap.add peer addr peer network
            | Send ( dest addr , transport , data ) →
                  begin
                     let dest addr int , port = match dest addr with
                        | Unix .ADDR INET ( dest , port ) →
                             let , a2 , a3 , a4 = Scanf .sscanf (Unix .string of inet addr dest) "%d.%d.%d.%d" (fun w x y z →
w , x , y, z ) in
                                a2 + a3 + a4 , port
                        |    → failwith "Debugger : treat network output : did not received an Inet address ?!"
                     in
                        try
                           ignore(List.find ((=) (port, transport)) (NetworkMap.find dest addr int network ).listening ports);
                                                                                                     97

                 let peer address = Unix .ADDR INET ( peer .address , port ) in
                 let packet = match transport with
                    | TCP →
                         TCP in ( peer address , data )
                    | UDP →
                         UDP in ( peer address , data )
                 in
                 let dest = NetworkMap.find dest addr int network in
                 let dest = { dest with pending network = packet :: dest.pending network } in
                 let peer = { peer with pending network = ( Sent ( dest addr , transport, data ) ) :: peer .pending netwo
                    NetworkMap.add dest addr int dest (NetworkMap.add peer addr peer network )
               with
                 |     →
                       begin
                         match transport with
                            | TCP →
                                let peer = { peer with pending network = ( Send failed ( dest addr , transport , data ) )
                                   NetworkMap.add peer addr peer network
                            |   →
                                network
                       end
          end
      | Network do nothing → network
let treat user output network peer addr time output =
   let feedback = User .user interface peer addr time output in
      begin
         match feedback with
           | Some x →
               let peer = NetworkMap.find peer addr network in
               let peer = { peer with pending user = x :: peer .pending user } in
                  NetworkMap.add peer addr peer network
           | None → network
      end
let treat time output network peer addr time output =
   let peer = NetworkMap.find peer addr network in
   let feedbacks , timer queue = Timer .timer interface peer addr time output peer .timer queue in
   let peer = { peer with timer queue = timer queue } in
   let peer = { peer with pending timer = feedbacks @ peer .pending timer } in
      NetworkMap.add peer addr peer network
let treat output network peer addr time output =
   match output with
      | Network out network action → treat network output network peer addr time network action
      | User out user action → treat user output network peer addr time user action
      | Timer out timer action → treat time output network peer addr time timer action
      | Do nothing → network
let step peer time peer addr inputs network =
   let peer = NetworkMap.find peer addr network in
   let arrow = peer .process in
98                                                               CHAPTER 19. MODULE CLI AST EXEC

       let arrow = EF .clone arrow arrow in
       let outputs = EF .run arrow (float of int time) (fun → 1.) (fun s → Printf .printf "[%d] %d : %s" time peer addr s
       let peer = { peer with process = arrow } in
       let network = NetworkMap.add peer addr peer network in
          List.fold left
            (fun network output → treat output network peer addr time output)
            network
            outputs
     let list of events peer event selection =
        let timer feedbacks = List.map (fun x → ‘Timer in x ) peer .pending timer in
        let user feedbacks = List.map (fun x → ‘User in x ) peer .pending user in
        let network feedbacks = List.map (fun x → ‘Network in x ) peer .pending network in
        let all events = timer feedbacks @ user feedbacks @ network feedbacks in
        let rec select event event selection =
           match event selection with
              | AllEvents → all events
              | Event ( queue , index ) →
                   begin match queue with
                     | Pending network → [ List.nth network feedbacks index ]
                     | Pending user → [ List.nth user feedbacks index ]
                     | Pending timer → [ List.nth timer feedbacks index ]
                   end
              | Events [ ] → [ ]
              | Events ( h :: t ) → ( List.hd ( select event (Event h) ) ) :: ( select event (Events t) )
        in
           select event event selection
  let step network time network =
     NetworkMap.fold
        (fun peer addr peer network →
            let peer = NetworkMap.find peer addr network in
            let feedbacks , timer queue = Timer .timed out time peer .timer queue in
            let peer = { peer with
                              timer queue = timer queue ;
                              pending timer = feedbacks @ peer .pending timer } in
            let inputs = list of events peer AllEvents in
            let peer = { peer with
                              pending user = [ ] ;
                              pending timer = [ ] ;
                              pending network = [ ] } in
            let network = NetworkMap.add peer addr peer network in
               step peer time peer addr inputs network )
        network
        network
  let rec exec step network time i network =
     match i with
        | 0 → ( time , network )
        |   →
            exec step network (time + 1) (i − 1) (step network time network )
                                                                                                     99

let rec exec step peers time peers network =
   match peers with
      | [ ] → network
      | peer addr :: t →
            let peer = NetworkMap.find peer addr network in
            let feedbacks , timer queue = Timer .timed out time peer .timer queue in
            let peer = { peer with
                              timer queue = timer queue ;
                              pending timer = feedbacks @ peer .pending timer } in
            let inputs = list of events peer AllEvents in
            let peer = { peer with
                              pending user = [ ] ;
                              pending timer = [ ] ;
                              pending network = [ ] } in
            let network = NetworkMap.add peer addr peer network in
               exec step peers time t (step peer time peer addr inputs network )
let exec step peer time peer addr input network =
   step peer time peer addr input network
let exec step command time history network =
   let ( new time , new network ) =
      match command with
         | TimeStepping i →
             Printf .printf "Time: %d -> %d\n" time (time + i );
             ( time + i , network )
         | Network i → exec step network time i network
         | PeersStepping peers → ( time + 1 , exec step peers time peers network )
         | PeerStepping ( peer addr , event selection ) →
             let peer = NetworkMap.find peer addr network in
             let feedbacks , timer queue = Timer .timed out time peer .timer queue in
             let peer = { peer with
                               timer queue = timer queue ;
                               pending timer = feedbacks @ peer .pending timer } in
             let inputs = list of events peer event selection in
             let filter out encaps list = List.filter (fun elt → ¬ ( List.mem (encaps elt) inputs)) list in
             let peer = { peer with
                               pending user = filter out (fun x → ‘User in x ) peer .pending user ;
                               pending timer = filter out (fun x → ‘Timer in x ) peer .pending timer ;
                               pending network = filter out (fun x → ‘Network in x ) peer .pending network } in
             let network = NetworkMap.add peer addr peer network in
                ( time + 1 , exec step peer time peer addr inputs network )
   in
      ( new time , ( time , network ) :: history , new network )
let rec exec backstep command time history network =
   match command with
      | Back 0 → ( time , history , network )
      | Back i →
          match history with
            | [ ] → ( time , history , network )
100                                                        CHAPTER 19. MODULE CLI AST EXEC

            | ( time , network ) :: history →
                 exec backstep (Back (i − 1)) time history network
  let exec help general () =
     Printf .printf "Available commands:\n";
     Printf .printf "\tshow: show the state of the network\n";
     Printf .printf "\tstep: take a step\n";
     Printf .printf "\tbackstep: take a step in the past\n";
     Printf .printf "\thelp: get some help\n";
     Printf .printf "\tquit: quit the debugger\n";
     Printf .printf "To get more info about a command, type \"help command\"\n"
  let rec exec help on show peer command =
     match command with
        | AllHelpShowPeer →
            Printf .printf "Available commands under \"show peer ID\"\n";
            List.iter exec help on show peer [ OnNetEvents ; OnTimerEvents ; OnUserEvents ; OnRegistredTimers ;
                                                  OnOpenPorts ; OnState ];
            Printf .printf "\tshow peer ID all:\t\tprint all previous informations\n";
        | OnNetEvents →
            Printf .printf "\tshow peer ID net events:\tprint the pending network events of the given peer\n";
        | OnTimerEvents →
            Printf .printf "\tshow peer ID timer events:\tprint the pending timer events of the given peer\n";
        | OnUserEvents →
            Printf .printf "\tshow peer ID user events:\tprint the pending user events of the given peer\n";
        | OnRegistredTimers →
            Printf .printf "\tshow peer ID registred timers:\tprint the registred timers of the given peer\n";
        | OnOpenPorts →
            Printf .printf "\tshow peer ID ports:\tprint the open ports of the given peer\n";
        | OnState →
            Printf .printf "\tshow peer ID state STATE ID:\tprint the value of the given state for the peer\n"
  let exec help on show command =
     match command with
       | AllHelpShow →
            Printf .printf "Available commands under \"show\":\n";
            Printf .printf "\tshow network:\tprint the state of the network\n";
            Printf .printf "\tshow peer ID:\tprint the state of the peer number ID\n";
            Printf .printf "\tshow peer ID (...):\tsee \"help show peer\"\n";
       | HelpShowOnNetwork →
            Printf .printf "\tshow network:\tprintf the state of the whole network\n";
       | HelpShowOnPeer showOnPeer →
            exec help on show peer showOnPeer
  let rec exec help on step command =
     match command with
        | AllHelpStep →
            Printf .printf "Available commands under \"step\":\n";
            List.iter exec help on step [ OnNetwork ; OnPeers ; OnTime ];
            Printf .printf "\tstep peer ID (...):\tsee \"help step peer\"\n";
        | OnNetwork →
            Printf .printf "\tstep network N rounds:\tthe whole network takes a step\n";
                                                                                            101

      | OnPeers →
          Printf .printf   "\tstep peers [ ID ; ... ; ID ]:\tthe selected peers take a step\n";
      | OnPeer →
          Printf .printf   "Available commands under \"step peer ID\":\n";
          Printf .printf   "\tstep peer ID event all:\tProcess all pending events on peer ID\n";
          Printf .printf   "\tstep peer ID event EID:\tProcess pending event EID on peer ID\n";
          Printf .printf   "\tstep peer ID event [ EID ; ... ; EID ]:\tProcess pending events [ EID ; ... ; EI
      | OnTime →
          Printf .printf   "\tstep time N:\tincrease the time by N > 0 seconds\n"
  let exec help on back     =
     Printf .printf "Available commands under \"backstep\":\n";
     Printf .printf "\tbackstep N actions:\ttake N steps in the past\n";
     Printf .printf "\tbackstep:\t\ttake 1 step in the past\n"
  let exec help command time history network =
     begin
        match command with
          | OnHelp → exec help general ()
          | OnShow helpOnShow → exec help on show helpOnShow
          | OnStep helpOnStep → exec help on step helpOnStep
          | OnBack helpOnBack → exec help on back helpOnBack
     end ;
     ( time , history , network )
  let exec command command =
     match command with
       | Show s → exec show s
       | Step s → exec step s
       | Backstep s → exec backstep s
       | Help s → exec help s
       | Quit
       | Eol → failwith "exec comand: impossible"
end
102   CHAPTER 19. MODULE CLI AST EXEC
          Part V

The Model-Checker Launcher




            103
Chapter 20

Module Modelchecker signatures

module type MODELCHECKER USER =
sig
   type user feedback
   type user action

  val print user feedback : Format.formatter → user feedback → unit
  val print user action : Format.formatter → user action → unit

  val user interface : int → float → user action → user feedback option
  val init : int → user feedback

end

module type MODELCHECKER TIMER =
sig

  * Import the user-defined types

  include (Signatures.TIMER TYPES )

  module TimersQueue :
  sig
     type t
     type queue
     val create : unit → queue
     val insert : float → t → queue → queue
     val remove : t → queue → queue
     val peek until : float → queue → t list × queue
     val size queue : queue → int
     val print queue : Format.formatter → queue → unit
     val signature queue : queue → string
  end




                                              105
106                                       CHAPTER 20. MODULE MODELCHECKER SIGNATURES

20.1      Type definitions
  type timer type =
    | Periodic (∗ Will be raised every t period ∗)
    | Unique (∗ Will be raised once, in t ∗)
  timer defines the complete structure of a timer
  type timer =
       {
         delay : float ; (∗ the delay between now and when the timer must trigger ∗)
         timer type : timer type ; (∗ the periodicity of the timer ∗)
         command : timers (∗ the command triggered by the timer ∗)
       }
  timer feedback defines the commands that the Timer can send to the arrow
  type timer feedback =
    | Timeout of timer
    | Timer up of timer
    | Timer killed of timer
  timer action defines the commands that can be sent by the arrow to the Timer
  type timer action =
    | Launch timer of timer
    | Kill timer of timer
    | Timer do nothing




20.2      Pretty-printers
  val print timer feedback : Format.formatter → timer feedback → unit
  val print timer action : Format.formatter → timer action → unit




20.3      Timer interface
  val timer do nothing : timer action
  val signature feedback : timer feedback → string
  val is synchronous : timer feedback → bool
  val timed out : float → TimersQueue.queue → timer feedback list × TimersQueue.queue
  val timer interface : int → float → timer action → TimersQueue.queue → timer feedback list × TimersQueue.queue
end
module type MODELCHECKER PROPERTIES =
sig
20.3. TIMER INTERFACE                                                                                     107

  val network size : int
  val rand : float → float
  val printer : string → unit
end
module EF = Event function
module type PROPERTY =
   functor ( NetworkMap : Map.S with type key = int ) →
sig
  module Timer : MODELCHECKER TIMER
  module User : MODELCHECKER USER
  module Network : Signatures.NETWORK
  module Peer :
  sig
      type (α, β) peer =
           {
             process : (α, β) EF .arrow ;
             printer : int → string → unit ;
             address : Unix .inet addr ;
             pending timer : Timer .timer feedback list ;
             pending user : User .user feedback list ;
             pending network : Network .net feedback list ;
             listening ports : ( int × Network .transport ) list ;
             timer queue : Timer .TimersQueue.queue ;
           }
      val   make empty peer : (α, β) EF .arrow → int → (α, β) peer
      val   signature of peer : (α, β) peer → string
      val   collect network events : (α, β) peer → (Network .net feedback × (α, β) peer ) list
      val   collect timer events : (α, β) peer → (Timer .timer feedback × (α, β) peer ) list
      val   peer collect events : (α, β) peer → ([> ‘Network in of Network .net feedback
                                                       | ‘Timer in of Timer .timer feedback ] × (α, β) peer ) list
  end
  type property = Safety
                  | Liveness
                  | Safety partial
                  | Bounded safety of int
  val kind of property : property
  val property : (α, β) Peer .peer NetworkMap.t → bool
end
108   CHAPTER 20. MODULE MODELCHECKER SIGNATURES
Chapter 21

Module Modelchecker peer

open Hash
module EF = Event function
module Make
   ( User : Modelchecker signatures.MODELCHECKER USER )
   ( Timer : Modelchecker signatures.MODELCHECKER TIMER )
   ( NetworkTypes : Signatures.NETWORK TYPES )
   =
struct
 module NetworkInterfaceTypes = Network interface types.NetworkInterfaceTypes ( NetworkTypes )
 module Network = NetworkInterfaceTypes
 type (α, β) peer =
      {
        process : (α, β) EF .arrow ;
        printer : int → string → unit ;
        address : Unix .inet addr ;
        pending timer : Timer .timer feedback list ;
        pending user : User .user feedback list ;
        pending network : Network .net feedback list ;
        listening ports : ( int × Network .transport ) list ;
        timer queue : Timer .TimersQueue.queue ;
      }
 let make empty peer arrow address =
    {
      address = Int to inet.inet addr of int address ;
      printer = (fun time string → Printf .printf "[%d] %d : %s" time address string ) ;
      process = arrow ;
      pending timer = [ ] ;
      pending user = [User .init address] ;
      pending network = [ ] ;
      listening ports = [ ] ;
      timer queue = Timer .TimersQueue.create () ;
    }


                                                    109
110                                                 CHAPTER 21. MODULE MODELCHECKER PEER

 let signature of peer peer =
    let signature ef = EF .signature arrow peer .process in
    let signature timers = List.fold left (ˆ) "" (List.sort compare (List.map Timer .signature feedback peer .pending timer )
    let signature network = List.fold left (ˆ) "" (List.sort compare (List.map Network .signature feedback peer .pending net
    let signature listening ports =
       List.fold left
          (ˆ)
          ""
          (List.sort
              compare
              (List.map
                 (fun (port, transport) →
                     ( string of int port ) ˆ ":" ˆ (Network .signature of transport transport)) peer .listening ports))
    in
    let signature =
       signature ef ˆ
          (hash signature timers) ˆ
          (hash signature network ) ˆ
          (hash signature listening ports) ˆ
          (hash (Timer .TimersQueue.signature queue peer .timer queue))
    in
       hash signature
  let collect network events peer =
     let network events = peer .pending network in
     let rec collect int previous events events =
        match events with
           | [] → []
           | h :: t →
                let event = h , { peer with pending network = previous events @ t } in
                let events = collect int (h :: previous events) t in
                   event :: events
     in
        collect int [ ] network events
  let collect timer events peer =
     let timer events = peer .pending timer in
     let rec collect int previous events events =
        match events with
           | [] → []
           | h :: t →
                let event = h , { peer with pending timer = previous events @ t } in
                let events = collect int (h :: previous events) t in
                   event :: events
     in
        collect int [ ] timer events
  let peer collect events peer =
     let network events collection = List.map (fun ( x , peer ) → ( ‘Network in x , peer ) ) (collect network events peer ) in
     let timer events collection = List.map (fun ( x , peer ) → ( ‘Timer in x , peer ) ) (collect timer events peer ) in
        network events collection @ timer events collection
      111

end
112   CHAPTER 21. MODULE MODELCHECKER PEER
Chapter 22

Module Network map

module IntOrdered =
 struct
    type t = int
    let compare = ( compare : int → int → int )
 end
module NetworkMap = Map.Make ( IntOrdered )




                                              113
114   CHAPTER 22. MODULE NETWORK MAP
Chapter 23

Module Modelchecker timer

module Timer ( TimerTypes : Signatures.TIMER TYPES ) =
struct




23.1      Module imports
  Include the user-defined timers

  module TimerInterfaceTypes = Timer interface types.TimerInterfaceTypes( TimerTypes )
  include ( TimerInterfaceTypes )

  Build a priority queue for timers

  module OrderOnTimes =
  struct
     type t = timer
     let compare x t = compare x t.delay
     let get delay t = t.delay
     let print ppf t = print timer ppf t
  end
  module TimersQueue = Priority queue.Make ( OrderOnTimes )

  let timer do nothing = Timer do nothing




23.2      Utility
  refeed periodic time timers queue list of timers extracts the Periodic timers of list of timers and re-
inserts them in the priority queue

                                                  115
116                                              CHAPTER 23. MODULE MODELCHECKER TIMER

  let rec refeed periodic time timing queue timers =
     match timers with
        | [ ] → timing queue
        | ( { timer type = Periodic } as timer ) :: timers →
              refeed periodic time (TimersQueue.insert time timer timing queue) timers
        |     :: timers →
              refeed periodic time timing queue timers




23.3      Timer Interface
  timed out time timer queue gets all timers which have expired and the new timers queue.
    When Periodic timers are extracted, we re-feed them to the timers queue.
  let timed out time timing queue =
     let feedbacks , timing queue = TimersQueue.peek until time timing queue in
        ( List.map (fun x → Timeout x ) feedbacks ) , (refeed periodic time timing queue feedbacks)
  timer interface address current time timer action timers queue applies the timer action and replies
with pending events
  let timer interface address time timer action timing queue =
     let feedback , timing queue =
        match timer action with
           | Launch timer timer →
               [ Timer up timer ] , (TimersQueue.insert time timer timing queue)
           | Kill timer timer →
               [ Timer killed timer ] , (TimersQueue.remove timer timing queue)
           | Timer do nothing →
               [ ] , timing queue
     in let timed out , timing queue = timed out time timing queue in
        feedback @ timed out , timing queue
  let is synchronous timer =
     match timer with
        | Timeout    → false
        | Timer up
        | Timer killed  → true
  let signature feedback   timer =
     match timer with
        | Timer up
        | Timer killed     → ""
        | Timeout timer    →
            signature of   timer timer
end
Chapter 24

Module Modelchecker

open Network map
open Hash
module EF = Event function
module Make
   ( ModelcheckerProperties : Modelchecker signatures.MODELCHECKER PROPERTIES )
   ( PropertyM : Modelchecker signatures.PROPERTY )
   =
struct
 module Property = PropertyM ( Network map.NetworkMap )
 module Network = Property.Network
 module User = Property.User
 module Timer = Property.Timer
 open Network
 module Peer = Property.Peer
 open Property.Peer
 type multiplexer input =
      [
      | ‘Network in of Network .net feedback
      | ‘User in of User .user feedback
      | ‘Timer in of Timer .timer feedback
      ]
 type multiplexer output =
   | Network out of Network .net action
   | User out of User .user action
   | Timer out of Timer .timer action
   | Do nothing
 let string of multiplexer in ppf input =
       match input with
         | ‘Network in net → Format.fprintf ppf "@[Network in: %a@]" Network .print net feedback net
         | ‘User in user → Format.fprintf ppf "@[User in: %a@]" User .print user feedback user
         | ‘Timer in timer → Format.fprintf ppf "@[Timer in: %a@]" Timer .print timer feedback timer

                                               117
118                                                           CHAPTER 24. MODULE MODELCHECKER

  let string of multiplexer out ppf output =
     match output with
        | Network out net → Format.fprintf ppf "@[Network out: %a@]" Network .print net action net
        | User out user → Format.fprintf ppf "@[User out: %a@]" User .print user action user
        | Timer out timer → Format.fprintf ppf "@[Timer out: %a@]" Timer .print timer action timer
        | Do nothing → Format.fprintf ppf "@[%s@]" "Do nothing"
 let signature network network =
    let signatures = NetworkMap.map Peer .signature of peer network in
    let signature = NetworkMap.fold (fun key value res → value ˆ res) signatures "" in
       hash signature
 let int of inet addr addr =
     let , a2 , a3 , a4 = Scanf .sscanf (Unix .string of inet addr addr ) "%d.%d.%d.%d" (fun w x y z →
w , x , y, z ) in
         a2 + a3 + a4
  let treat network output network time peer addr output =
     let peer = NetworkMap.find peer addr network in
        match output with
          | Listen on ( port , transport ) →
              begin
                 try
                    ignore(List.assoc port peer .listening ports);
                    network , [ ‘Network in (Listening on ( port , transport )) ]
                 with
                    | Not found →
                        let peer = { peer with listening ports = ( port , transport ) :: peer .listening ports } in
                        let network = NetworkMap.add peer addr peer network in
                           network , [ ‘Network in (Listening on ( port , transport )) ]
              end
         | Close connection ( port , transport ) →
             let peer = { peer with listening ports = List.filter ((=) (port, transport)) peer .listening ports } in
             let network = NetworkMap.add peer addr peer network in
                network , [ ‘Network in (Connection closed ( port , transport )) ]
         | Send ( dest addr , transport , data ) →
             begin
               let dest addr int , port = match dest addr with
                  | Unix .ADDR INET ( dest , port ) →
                        (int of inet addr dest) , port
                  |    → failwith "Model-checker : treat network output : did not received an Inet address ?!"
               in
                  try
                     ignore(List.find ((=) (port, transport)) (NetworkMap.find dest addr int network ).listening ports);
                     let peer address = Unix .ADDR INET ( peer .address , port ) in
                     let packet = match transport with
                        | TCP →
                             TCP in ( peer address , data )
                        | UDP →
                             UDP in ( peer address , data )
                                                                                                   119

                 in
                 let dest = NetworkMap.find dest addr int network in
                 let dest = { dest with pending network = packet :: dest.pending network } in
                 let network = NetworkMap.add dest addr int dest network in
                    network , [ ‘Network in (Sent ( dest addr , transport, data )) ]
               with
                 |    →
                      begin
                         match transport with
                           | TCP →
                               network , [ ‘Network in (Send failed ( dest addr , transport , data )) ]
                           |   →
                               network , [ ]
                      end
          end
      | Network do nothing →
          network , [ ]
let treat timer output network time peer addr output =
   let peer = NetworkMap.find peer addr network in
   let feedbacks , timer queue = Timer .timer interface peer addr time output peer .timer queue in
   let peer = { peer with timer queue = timer queue } in
   let synchronous timer input , asynchronous timer input = List.partition Timer .is synchronous feedbacks in
   let peer = { peer with pending timer = asynchronous timer input @ peer .pending timer } in
   let network = NetworkMap.add peer addr peer network in
   let synchronous timer input = List.map (fun x → ‘Timer in x ) synchronous timer input in
      network , synchronous timer input
let treat user output network time peer addr output =
   let feedback = User .user interface peer addr time output in
      begin
         match feedback with
           | Some x → network , [ ‘User in x ]
           | None → network , [ ]
      end
let treat output network time src addr output =
   let network , inputs =
      match output with
        | Network out network action → treat network output network time src addr network action
        | Timer out timer action → treat timer output network time src addr timer action
        | User out user action → treat user output network time src addr user action
        | Do nothing → network , [ ]
   in
   let network , inputs = treat timer output network time src addr Timer .timer do nothing in
      network , ( inputs @ inputs )
let rec zip with constant x l =
   match l with
      | [] → []
      | h :: t → ( x , h ) :: zip with constant x t
120                                                         CHAPTER 24. MODULE MODELCHECKER

  let rec take step network time rand printer ( addr , event ) =
     let peer = NetworkMap.find addr network in
     let event function = EF .clone arrow peer .process in
     let outputs = EF .run event function time rand printer [ event ] in
     let network = NetworkMap.add addr { peer with process = event function } network in
     let ( network , synchronous inputs ) =
           List.fold left
             (fun ( network , inputs ) output →
                   let network , new inputs = treat output network time addr output in
                      network , inputs @ ( List.rev new inputs ) )
             ( network , [ ] )
             outputs
        in
           match synchronous inputs with
           | [ ] → network
           |     →
                 let network =
                     List.fold left
                       ( fun network ( addr , event ) → take step network time rand printer ( addr , event ) )
                       network
                       (zip with constant addr synchronous inputs)
                 in
                     network
  let initialize network network time rand printer =
     NetworkMap.fold
        (fun addr peer network → take step network time rand printer ( addr , ‘User in ( List.hd peer .pending user ) ) )
        network
        network
  let collect events network =
     let all events =
        NetworkMap.mapi
          (fun key peer peer →
              let event new peer s = peer collect events peer in
                 List.map
                   (fun ( event , new peer ) →
                       let new network = NetworkMap.add key peer new peer network in
                          ( key peer , event) , new network )
                   event new peer s
          )
          network
     in
        NetworkMap.fold
          (fun key peer event collection all event collection →
              peer event collection @ all event collection)
          all events
          []
  module StateSpace = Hashtbl .Make ( struct
                                          type t = string
                                                                                                  121

                                                let equal = (=)
                                                let hash = Hashtbl .hash
                                              end )
let state space = StateSpace.create 1000
let bounded state space = StateSpace.create 1000
exception Exists timer
let exists timer network =
   try
      ignore (
         NetworkMap.iter
            (fun addr peer →
                if ( Timer .TimersQueue.size queue peer .timer queue > 0 ) then
                   raise Exists timer
            )
            network );
      false
   with
      | Exists timer → true
type α transition =
     { index : int
     ; event : multiplexer input
     ; peer : int
     ; state before : α NetworkMap.t
     ; signature state before : string }
type α transition    sequence =
     { transitions    : α transition list ;
        last state   : α NetworkMap.t ;
        max dom      : int }
let is dependent transition1 transition2 =
   match ( transition1 , transition2 ) with
      | { peer = x ; event = ‘Timer in } , { peer = y ; event = ‘Timer in }
      | { peer = x ; event = ‘User in } , { peer = y ; event = ‘User in }
      | { peer = x ; event = ‘Timer in } , { peer = y ; event = ‘User in }
      | { peer = x ; event = ‘User in } , { peer = y ; event = ‘Timer in }
      | { peer = x ; event = ‘User in } , { peer = y ; event = ‘Network in }
      | { peer = x ; event = ‘Network in } , { peer = y ; event = ‘User in }
      | { peer = x ; event = ‘Timer in } , { peer = y ; event = ‘Network in }
      | { peer = x ; event = ‘Network in } , { peer = y ; event = ‘Timer in } →
           x = y
      | { peer = x ; event = ‘Network in (TCP in ( Unix .ADDR INET ( sender addr1 ,      ),     )) } ,
           { peer = y ; event = ‘Network in (TCP in ( Unix .ADDR INET ( sender addr2 ,     ),     )) }
      | { peer = x ; event = ‘Network in (TCP in ( Unix .ADDR INET ( sender addr1 ,       ),     )) } ,
           { peer = y ; event = ‘Network in (UDP in ( Unix .ADDR INET ( sender addr2 ,     ),     )) }
      | { peer = x ; event = ‘Network in (UDP in ( Unix .ADDR INET ( sender addr1 ,       ),     )) } ,
           { peer = y ; event = ‘Network in (TCP in ( Unix .ADDR INET ( sender addr2 ,     ),     )) }
      | { peer = x ; event = ‘Network in (UDP in ( Unix .ADDR INET ( sender addr1 ,       ),     )) } ,
           { peer = y ; event = ‘Network in (UDP in ( Unix .ADDR INET ( sender addr2 ,   ),     )) } →
122                                                           CHAPTER 24. MODULE MODELCHECKER



           let sender addr1 = int of inet addr sender addr1 in
           let sender addr2 = int of inet addr sender addr2 in
              x = y ∨
                x = sender addr2 ∨
                sender addr1 = y ∨
                sender addr1 = sender addr2
      | { peer = x ; event = ‘Network in } , { peer = y ; event = ‘Network in               } → x = y

  let take empty step network time rand printer =
     let take empty step int network time rand printer =
        let network , inputs =
           NetworkMap.fold
              (fun key peer (network , inputs) →
                  let ( network , new inputs ) = treat timer output network time key Timer .timer do nothing in
                     ( network , inputs @ (List.rev new inputs) )
              )
              network
              (network , [ ])
        in
           if (inputs = [ ]) then
              failwith "take empty step: non empty feedback";
           network
     in
     let rec search timer time network events =
        if ( exists timer network ∧ events = [ ] ) then
           begin
              let network = take empty step int network (time + .1.) rand printer in
                 search timer (time + .1.) network (collect events network )
           end
        else
           ( network , time , events )
     in
        search timer time network (collect events network )

  let iter peers network state action =
     NetworkMap.iter (fun peer id     → action peer id ) network state

 let collect events peer network p =
    let peer = NetworkMap.find p network in
       peer collect events peer

  let transition is enabled state peer id transition =
     let transitions = List.map fst (collect events peer state peer id ) in
        List.mem transition.event transitions

  let peer is enabled state peer id =
     let transitions = collect events peer state peer id in
        transitions = [ ]
                                                                                  123

let enabled peers state =
   NetworkMap.fold
     (fun peer id peer state enabled peer →
         match enabled peer with
           | Some      → enabled peer
           | None →
               let events = peer collect events peer state in
                  if events = [ ] then
                     None
                  else
                     Some peer id )
     state
     None
module IntCompare =
 struct
    type t = int
    let compare = ( compare : int → int → int )
 end
module IntMap = Map.Make ( IntCompare )
let not happens before clock vector peer peer transition =
   let clock =
      try
         IntMap.find transition.peer (IntMap.find peer clock vector peer )
      with
         | Not found → 0
   in
      transition.index > clock
let latest transition l =
   match l with
      | [ ] → None
      |     →
            let max =
               List.fold right
                 (fun transition max id → max transition.index max id )
                 l 0
            in
               Some max
let nth state transition sequence n =
   assert( n > 0 );
   assert( n < transition sequence.max dom );
   let transition = List.nth transition sequence.transitions n in
      ( transition.state before , transition.signature state before )
let rec peek any element set forbidden set =
   match set with
      | [ ] → None
      | h :: t when List.mem h forbidden set → peek any element t forbidden set
      | h ::    → Some h
124                                                      CHAPTER 24. MODULE MODELCHECKER

  module StringH =
   struct
      type t = string
      let equal = ( (=) : string → string → bool )
      let hash = Hashtbl .hash
   end

  module StringHash = Hashtbl .Make ( StringH )

  let backtrack = StringHash.create 100

  let max clock vector clock vector 1 clock vector 2 =
     IntMap.mapi
       (fun peer id value 1 →
           let value 2 =
              try
                 IntMap.find peer id clock vector 2
              with
                 | Not found → 0
           in
              max value 1 value 2 )
       clock vector 1

  let max clock vector of list clock vector peer dependent transitions =
     match dependent transitions with
       | [] →
                      IntMap.empty
       | [h ] →
            begin try
              IntMap.find h.index clock vector peer
            with
              | Not found → IntMap.empty
            end
       | h :: t →
            List.fold right
              (fun transition clock vector →
                  let fresh clock vector =
                     try
                        IntMap.find transition.peer clock vector peer
                     with
                        | Not found → IntMap.empty
                  in
                     max clock vector fresh clock vector clock vector )
              t
              (try
                  IntMap.find h.peer clock vector peer
                with
                  | Not found → IntMap.empty)
                                                                                                        125

let deterministic next transition state peer id =
   let next transitions = collect events peer state peer id in
   let hashed next transitions = List.map (fun x → ( Hashtbl .hash x , x )) next transitions in
   let sorted hashed next transitions = List.sort ( fun (x , ) (y, ) → compare x y ) hashed next transitions in
   let , next transitions = List.split sorted hashed next transitions in
      match next transitions with
         | [ ] → None
         | h ::   → Some h
exception Already visited state
exception Print stack
let check safety partial rand printer state safety property =
   let rec explore time state state signature transition sequence clock vector peer clock vector time =
      try
         begin
            try
               ignore( StateSpace.find state space state signature );
               raise Already visited state
            with
               | Not found →
                    StateSpace.add state space state signature true;
         end;
         if ¬ ( safety property state ) then
            raise Print stack ;
         iter peers state
            (fun peer id →
                                     match deterministic next transition state peer id with
                   | None → ()
                   | Some ( next transition , ) →
                       let next transition =
                          { index = transition sequence.max dom + 1
                          ; event = next transition
                          ; peer = peer id
                          ; state before = state
                          ; signature state before = state signature } in
                       let dependent transitions = List.filter (is dependent next transition) transition sequence.transitions i
                       let coenabled transitions = List.filter (transition is enabled state peer id ) dependent transitions in
                       let not happens before = List.filter (not happens before clock vector peer peer id ) coenabled transiti
                          match latest transition not happens before with
                             | None →
                                                                ()
                             | Some i →
                                  let ( state pre i , signature state pre i ) = nth state transition sequence i in
                                     if peer is enabled state pre i peer id then
                                        begin
                                           StringHash.add backtrack signature state pre i peer id ;
                                                                             end
                                     else
                                        begin
                                           iter peers state pre i
126                                                           CHAPTER 24. MODULE MODELCHECKER

                                          (fun peer id →
                                              if peer is enabled state pre i peer id then
                                                 StringHash.add backtrack signature state pre i peer id );
                                                                           end
                         );
            match enabled peers state with
              | None →
                              if ( exists timer state ) then
                      let ( state , time , ) = take empty step state (time + .1.) rand printer in
                      let state signature = signature network state in
                                             explore time state state signature transition sequence clock vector peer clock vector
                         ()
              | Some peer id →
                              StringHash.add backtrack state signature peer id ;
                   backtracker time state state signature transition sequence clock vector peer clock vector time [ ]
         with
            | Already visited state → ()
      and backtracker time state state signature transition sequence clock vector peer clock vector time peer done =
         let backtrack points = StringHash.find all backtrack state signature in
            match peek any element backtrack points peer done with
              | None → ()
              | Some peer id →
                   let peer done = peer id :: peer done in
                                           match deterministic next transition state peer id with
                         | None → ()
                         | Some ( event , peer ) →
                              let transition =
                                 { index = transition sequence.max dom
                                 ; event = event
                                 ; peer = peer id
                                 ; state before = state
                                 ; signature state before = state signature } in
                              let state = NetworkMap.add peer id peer state in
                                                  let state = take step state time rand printer ( peer id , event ) in
                              let state signature = signature network state in
                              let dependent transitions = List.filter (is dependent transition) transition sequence.transitions in
                              let clock vector1 = max clock vector of list clock vector time dependent transitions in
                              let clock vector2 = IntMap.add peer id (transition sequence.max dom + 1) clock vector1 in
                              let clock vector time = IntMap.add (transition sequence.max dom + 1) clock vector2 clock vecto
                              let clock vector peer = IntMap.add peer id clock vector2 clock vector peer in
                              let transition sequence =
                                 { transitions = transition sequence.transitions @ [ transition ]
                                 ; last state = state
                                 ; max dom = transition sequence.max dom + 1 } in
                                 explore time state state signature transition sequence clock vector peer clock vector time ;
                                 backtracker time state state signature transition sequence clock vector peer clock vector time pe
      in
      let state signature = signature network state in
      let transition sequence =
                                                                                                127

    { transitions = [ ] ;
       last state = state ;
       max dom = 0 }
  in
  let clock vector peer , clock vector time = (fun x → (x , x )) IntMap.empty
  in
     explore 0. state state signature transition sequence clock vector peer clock vector time
exception Increment time of float
exception Succeed
let check safety rand printer network safety property =
   let rec check safety int time rand printer network depth =
      if ¬ ( safety property network ) then
         raise Print stack
      else
         let pending state events = collect events network in
            List.iter
              (fun ( ( addr , event ) , network ) →
                  let network = take step network time rand printer ( addr , event ) in
                  let signature network = signature network network in
                     try
                        begin
                           try
                              ignore( StateSpace.find state space signature network );
                              raise Already visited state
                           with
                                 | Not found → ()
                        end;
                        let state size = StateSpace.length state space in
                           if ( state size mod 100 = 0 ) then
                              begin
                                 Printf .printf "State size: %d\n" state size;
                                 flush stdout;
                              end;
                     StateSpace.add state space signature network true;
                     try
                        check safety int time rand printer network (depth + 1);
                     with
                        | Print stack →
                            Format.printf "Stack [%d] : " depth;
                            Format.printf "Host %d <- " addr ;
                            string of multiplexer in Format.std formatter event;
                            Format.print newline ();
                            raise Print stack ;
                 with
                   | Already visited state → ()
           )
           pending state events;
128                                                           CHAPTER 24. MODULE MODELCHECKER

               if ( pending state events = [ ] ∧ exists timer network ) then
                  let ( network , time , ) = take empty step network (time + .1.) rand printer in
                     check safety int time rand printer network depth;
      in
           StateSpace.add state space (signature network network ) true;
           check safety int 0. rand printer network 0
 let bounded check safety rand printer network safety property bound =
    let rec check safety int time rand printer network depth =
       if depth < bound then
          if ¬ ( safety property network ) then
             raise Print stack
          else
             try
                let pending state events = collect events network in
                   List.iter
                     (fun ( ( addr , event ) , network ) →
                         let network = take step network time rand printer ( addr , event ) in
                         let signature network = signature network network in
                            try
                               begin
                                  try
                                     let depth explored = StateSpace.find bounded state space signature network in
                                        if ( depth explored ≤ depth ) then
                                           raise Already visited state;
                                  with
                                     | Not found → ()
                               end;
                               let state size = StateSpace.length bounded state space in
                                  if ( state size mod 100 = 0 ) then
                                     Printf .printf "State size: %d\n" state size;
                                  StateSpace.add bounded state space signature network depth;
                                try
                                   check safety int (time + .1.) rand printer network (depth + 1);
                                with
                                   | Increment time t →
                                       check safety int t rand printer network (depth + 1);
                           with
                             | Already visited state → ()
                      )
                      pending state events;
                   if ( pending state events = [ ] ∧ exists timer network ) then
                      raise ( Increment time (time + .1.) );
               with
                  | Print stack →
                      Printf .printf "Print stack...\n";
                      raise Print stack
               else
                  ()
                                                                                                   129

  in
       StateSpace.add bounded state space (signature network network ) 0;
       check safety int 0. rand printer network 1
let model check network =
   let network = initialize network network 2. ModelcheckerProperties.rand ModelcheckerProperties.printer
   in
      begin
        match Property.kind of property with
           | Property.Liveness → failwith "Not implemented"
           | Property.Safety →
               begin
                 try
                    check safety
                      ModelcheckerProperties.rand
                      ModelcheckerProperties.printer
                      network
                      Property.property;
                    Printf .printf "Safety ensured\n"
                 with
                    | Print stack →
                        Printf .printf "Safety broken\n";
               end
           | Property.Bounded safety bound →
               begin
                 try
                    bounded check safety
                      ModelcheckerProperties.rand
                      ModelcheckerProperties.printer
                      network
                      Property.property
                      bound ;
                    Printf .printf "Safety ensured\n"
                 with
                    | Print stack →
                        Printf .printf "Safety broken\n";
               end
           | Property.Safety partial →
               try
                  check safety partial
                    ModelcheckerProperties.rand
                    ModelcheckerProperties.printer
                    network
                    Property.property;
                  Printf .printf "Safety (partial) ensured\n"
               with
                  | Print stack →
                      Printf .printf "Safety (partial) broken\n"
       end;
       Printf .printf "No. explored states: %d\n" (StateSpace.length state space);
130                                                   CHAPTER 24. MODULE MODELCHECKER

      Printf .printf "No. explored bounded states: %d\n" (StateSpace.length bounded state space)
end
Chapter 25

Module Modelchecker launcher

open Network map
module EF = Event function
module Launcher
   ( ModelcheckerProperties : Modelchecker signatures.MODELCHECKER PROPERTIES )
   ( Property : Modelchecker signatures.PROPERTY ) =
struct
  module ModelChecker = Modelchecker .Make
   ( ModelcheckerProperties )
   ( Property )
  include ModelChecker
  open ModelChecker .Property.Peer
  let network init no peers arrow =
     let rec net init int peer arrow network =
        if peer = no peers then
           network
        else
           let network = NetworkMap.add peer (make empty peer arrow peer ) network in
              net init int (peer + 1) arrow network
     in
        net init int 0 arrow NetworkMap.empty
  let launcher arrow =
      Printf .printf "[] Setup the network... ";
      flush stdout;
      let network = network init ModelcheckerProperties.network size arrow in
         Printf .printf "Done.\n";
         flush stdout;
        model check network
end



                                                  131
132   CHAPTER 25. MODULE MODELCHECKER LAUNCHER
 Part VI

Examples




   133
Chapter 26

The Ping-pong tutorial

26.1      Module Pingpong messages
type message =
  | Ping
  | Pong
let print message ppf message =
   match message with
     | Ping → Format.fprintf ppf "%s" "Ping"
     | Pong → Format.fprintf ppf "%s" "Pong"
let signature of message message = Marshal .to string message [ ]
let to string message message = Marshal .to string message [ ]
let from string message string = ( Marshal .from string string 0 : message )


26.2      Module Pingpong timers
module Timers =
struct



26.2.1    Type definition
  timers throwable in the system
  type timers =
    | Send ping of Unix .sockaddr (∗ Periodically, request to send a ping to a given node ∗)



26.2.2    Pretty-printer
  print timers formater timers does what its name suggest
  let print timers ppf t =
     match t with
       | Send ping ( ) → Format.fprintf ppf "Send ping (...)"

                                                   135
136                                                          CHAPTER 26. THE PING-PONG TUTORIAL

  let signature of command (Send ping addr ) = "send ping:" ˆ (Net general .signature of addr addr )

end


26.3       Module Pingpong user
module User =
 struct




26.3.1      Type definitons
      user feedback corresponds to the event that the User can send to the arrow

      type user feedback =
        | Init (∗ Simply Init the system, i.e. we will be pinged ∗)
        | Init ping of Unix .sockaddr (∗ Initialize a ping, i.e. we will be the pinger ∗)

      No user action

      type user action = None action




26.3.2      Pretty-printer
      print user feedback formater user feedback

      let print user feedback ppf feedback =
         match feedback with
           | Init → Format.fprintf ppf "Init"
           | Init ping x → Format.fprintf ppf "Init ping ( SOMEONE )"

      print user action formater user action

      let print user action ppf action = Format.fprintf ppf "None action"

      user interface provides the interface for the Network Multiplexer

      let user interface ( channel multiplexer , channel user ) =
         try
            let to ping = Sys.argv .(2) in
               (∗ The second argument on the command line is destination IP ∗)
            let to ping = Unix .ADDR INET ( ( Unix .inet addr of string to ping ) , 40000 ) in
               Event.sync ( Event.send channel multiplexer (‘User in (Init ping to ping)))
         with
            |     →
                  (∗ There is no destination IP : we are the target ∗)
                  Event.sync ( Event.send channel multiplexer (‘User in Init) )

  end
26.4. MODULE PINGPONG                                                                               137

26.4     Module Pingpong
As we will use some timers, we must define them. That’s what is done in the module Pingpong timers where
timers are defined as well as a pretty-printer.
   Using this definition of our timers, we build a Timer module which can deal with our timers types and
provides functions to define, kill and raise timer interrupts.
Live deployment:

module Timer = Network timer .Timer ( Pingpong timers.Timers )
(∗ ] ∗)
(∗ For simulation/debugging: ∗)
(∗ module Timer = Simulator timer .Timer ( Pingpong timers.Timers ) ∗)
(∗ For Model-checking : ∗)
(∗ module Timer = Modelchecker timer .Timer ( Pingpong timers.Timers ) ∗)
The module Timer .Timer can be seen as a class using a Template, which is passed Pingpong timers.Timers
to instantiate a working class.


The Launcher is build on the same idea : it needs a Timer manager, a Network manager and a User manager.
    Here, we use the Timer module build previously.
    We use the basic Network manager that we wrote as a stand-alone library. But we could as well change
it at any time to a more sophisticated manager or even a simulator / model checker.
    And finally, the User manager is defined locally in Pingpong user .User . In this case, its job is to
get the command-line parameters and issues the right initialisation message : if there is an argument on
the command-line, we are an active pingpong trying to ping someone and we initialise the system with
Init ping peer address. Otherwise, we are a passive pingpong and we initialise the system with Init.
Live deployment:

module Launcher = Network launcher .Launcher
   ( Pingpong user .User )
   ( Timer )
   ( Pingpong messages )
(∗ ] ∗)
(∗ For simulation: ∗)
(∗ module Launcher = Simulator launcher .Launcher ( Simulation properties.SimulationProperties ) ( Pingpong simulated
∗)
(∗ For debugging: ∗)
(∗ module Launcher = Debugger launcher .Launcher ( Simulation properties.SimulationProperties ) ( Pingpong simulated
∗)
(∗ For Model-checking: ∗)
(∗ module Launcher = Modelchecker launcher .Launcher ( Modelchecking properties.ModelcheckingProperties ) ( Property.
∗)
Here we load the corresponding modules. Thus we can use the imported functions without prefixing them
by their module name, e.g. the function
Event function choice.EventFunctionChoice.arr can be called using arr
open Launcher
open Launcher .Network
open Event function
138                                                        CHAPTER 26. THE PING-PONG TUTORIAL

Live Deployement:

open Pingpong user .User
(∗ ] ∗)
(∗ For simulation/debugging: ∗)
(∗ open Pingpong simulated user .SimulatedUser ∗)
(∗ For Model-checking : ∗)
(∗ open Pingpong modelchecking user .ModelcheckingUser ∗)
open Pingpong timers.Timers
open Timer



26.4.1     Messages definition
Send up to max no pings pings.
let max no pings = 4
Sends a ping every ping interval seconds.
let ping interval = 2.
First, we define the messages exchanged over the network. In this case, it is very simple as we just have to
send Ping or Pong :
open Pingpong messages
Then, we can define some internal messages that will be exchanged between the components of the system.
By the way, the code is clearer and we can rely on the type-checker to catch our mistakes :
type pingpong internal =
  | Ping sent
  | Pong sent
  | Received ping from of Unix .inet addr
  | Received pong from of Unix .inet addr
  | None event



26.4.2     Input/Output management :


Outputs
First, we define some general output arrows :
let arr network action = pure ( fun query → Launcher .Network out query )
let arr timer action = pure ( fun query → Launcher .Timer out query )
let arr user action = pure ( fun query → Launcher .User out query )
Thus, in the following, we will be able to generalise any, say, Network out query through the arr network action,
simply by composing it.
26.4. MODULE PINGPONG                                                                                   139

Inputs



General Inputs     In order to dispatch the input requests to the corresponding arrow, we use a filter arrow
:
let filter query =
   match query with
     | ‘Network in x → Left ( Left x )
     | ‘Timer in x → Left ( Right (‘Timer in x ))
     | ‘User in x → Right x
let arr filter () = pure filter
The Left and Right variants are used to dispatch their argument to the corresponding side of a choice arrow.
Here, this choice arrow will have the following shape :
( arr network in ||| arr timer in ) ||| arr user in )


User inputs Again, we filter the user’s inputs by distinguishing a simple Init, meaning that we are
passively waiting for a Ping, and a Init ping peer , meaning that we have to actively Ping the peer .
let filter user query =
   match query with
     | Init → Left query
     | Init ping peer → Right query
let arr filter user = pure filter user
This filter will be composed with a choice arrow of the following shape :
arr passive init ||| arr active init



26.4.3     Reacting to User inputs
So far, we have wired the system such that the inputs will be cleanly dispatched into domain-specific
functions. Now, we have to code these functions. In this section, we will deal with the user’s inputs.


On the passive Pingpong side :
During the initialisation phase, the passive Pingpong has just to listen on UDP port 2000 :
let arr passive init listen = constant ( Listen on ( 40000 , UDP ) )
Then, we can generalise that to a Network action using arr network action :
let arr passive init = arr passive init listen >>> arr network action



On the active Pingpong side :
Firstly, we define our reactions which are :
let arr active init listen = constant ( Listen on ( 40001 , UDP ) )
140                                                          CHAPTER 26. THE PING-PONG TUTORIAL

Which will be send by an active Pingpong to listen on UDP port 2001

let active init ping m =
   match m with
     | Init ping peer →
          Launch timer
            {
               delay = 0.2 ;
               timer type = Unique ;
               command = Send ping peer
            }
     |    → failwith "Active init ping : filtering error"
let arr active init ping = pure active init ping

Which will launch a unique Timer that will ring in 0.2 seconds and orders to Send ping peer . By the way,
the listening socket has the time to be up before we receive the Pong of our Ping.

let active init timer m =
   match m with
     | Init ping peer →
          Launch timer
            {
               delay = ping interval ;
               timer type = Periodic ;
               command = Send ping peer
            }
     |    → failwith "Active init timer : filtering error"
let arr active init timer = pure active init timer

Which will launch a periodic Timer that will ring every ping interval seconds and orders to send another
ping.


And that’s it for the output commands. Now, we are able to wire these functions to shorten the notations.
First, we can wire the arr active init listen with arr network action to get the most general output :

let arr active init listen network action = arr active init listen >>> arr network action

Then, we could execute in parallel both timers’ initialisation arr active init ping and arr active init timer
:

let arr active init timers = arr active init ping &&| arr active init timer

Again, we could generalise this arrow with arr timer action :

let arr active init timers timer action = arr active init timers >>> arr timer action

Finally, we can execute in parallel the initialisation of the listening port and the initialisation of the timers,
obtaining the complete initialisation of the active ping

let arr active init = arr active init listen network action &&| arr active init timers timer action
26.4. MODULE PINGPONG                                                                                      141

Wrapping both sides
Here, we just to have to use the generalised arrows and compose them with the arr filter user :
let arr user = arr filter user >>> ( arr passive init ||| arr active init )
And that’s it for the user inputs.


26.4.4     Reacting to Network inputs
The first task when we receive a Network input is to marshal it into a typeable value. In OCaml, it is very
simple as we just have to use the function Marshal .from string data 0 : the desired type.
    As we are working on UDP packets, we have to look for a UDP in interrupt, extract the inet address,
type the message and transmit the query to the next function.
    When we send a packet, we get a confirmation Sent ( ... ) from the multiplexer. Here, we catch it, type
it and transmit the statement to the next function.
    For the sake of simplicity, all other events (such as errors) are ignored and are transmitted as None event
to the next function.
let marshal network query =
   match query with
     | UDP in ( peer , command ) →
         begin
           let peer addr = match peer with
              | Unix .ADDR INET ( addr , ) → addr
              |    → failwith "Marshall network : Not an INET ADDR !"
           in
              match command with
                | Ping → Received ping from peer addr
                | Pong → Received pong from peer addr
         end
     | Sent ( , , command ) →
         begin
           match command with
              | Ping → Ping sent
              | Pong → Pong sent
         end
     |   → None event
let arr marshall network = pure marshal network
Here, we react to the Network inputs. Basically, there is only one reaction, when we receive a ping : to send
a Pong. Otherwise, we might print some informations and transmit the order to do nothing, which can be
expressed by Network do nothing.
let react network (print, query) =
   match query with
      | Received ping from peer →
          print ("Ping from " ˆ (Unix .string of inet addr peer ) ˆ " !\n");
          flush stdout;
          Send ( Unix .ADDR INET (peer , 40001) , UDP , Pong )
      | Received pong from peer →
          print ("Pong from " ˆ (Unix .string of inet addr peer ) ˆ " !\n");
142                                                        CHAPTER 26. THE PING-PONG TUTORIAL

          flush stdout;
          Network do nothing
     | Ping sent →
          print "Wait for pong...\n";
          flush stdout;
          Network do nothing
     | Pong sent → Network do nothing
     | None event → Network do nothing
let arr react network = arr print react network

Now, we are able to completely wrap the network functions in a single one :

let arr network = arr marshall network >>> arr react network >>> arr network action

And that’s it on the network side.



26.4.5     Reacting to Timer inputs
This tutorial would not be complete if we were not to use the dloop combinator. So let’s do it !
    If you remember well the first section about initialisation, we instantiate two timers : a first timer will
ring uniquely after 0.2 seconds and a second timer will ring every 2 seconds.
    The idea here is to send a fixed amount of pings, say 5, thus requiring that we use a counter. We could
use a global variable but it’s not functional.
    That’s why we use the dloop combinator on function timer .
    The function timer takes a tuple composed of a query and a counter value, reacts to the query and
returns a tuple composed of this reaction and the counter incremented by one.
    If we have received a timer interrupt and if the counter is greater than, say, 5, we will kill the Periodic
timer by the appropriate command. Otherwise, we send a new ping.
    All other timer’s commands are ignored, for the sake of clarity.

let timer (query, counter ) =
   match query with
      | ‘Timer in (Timeout ( { command = Send ping peer } as timer )) →
          if counter < max no pings then
             (Network out (Send ( peer , UDP , Ping ))) , (counter + 1)
          else
             (Timer out (Kill timer timer )) , counter
      |   → Do nothing , counter

And finally, we enclose the timer in the dloop combinator :

let arr timer () = dloop ˜state id :"counter" 0 (pure timer )




26.4.6     Wiring the Pingpong
In order to get some debug information, we can use the following functions which simply retrieve the
command, print it using pre-defined pretty-printers and pass it to the next function:
26.5. MODULE PINGPONG SIMULATED USER                                                                   143

let printer multiplexer in input =
   Format.fprintf Format.std formatter "IN : %a\n@." Launcher .string of multiplexer in input;
   flush stdout;
   input
let arr printer multiplexer in () = pure printer multiplexer in

let printer multiplexer out output =
   Format.fprintf Format.std formatter "OUT : %a\n@." Launcher .string of multiplexer out output;
   flush stdout;
   output
let arr printer multiplexer out () = pure printer multiplexer out

Finally, we wrap every previously defined components into a single one, the pingpong function :

let pingpong () =
( arr filter () ) >>> ( ( arr network ||| (arr timer ()) ) ||| arr user )

(∗ First, we print the input command then we dispatch commands using arr filter depending on the origin
of the command. Each case is handled by the corresponding function arr network , arr timer and arr user
and each of these functions return a generalised output ready to be processed by the Launcher . Finally, we
print the output commands. ∗)



To run this function, we have simply to pass it to the multiplexer :

let =
   Launcher .launcher (pingpong ())

And we are done !


26.5      Module Pingpong simulated user

module SimulatedUser =
struct




26.5.1     Type definitions
  user feedback are events sent to the arrow

  type user feedback =
    | Init (∗ Initialize the event function, we will be pinged ∗)
    | Init ping of Unix .sockaddr (∗ Initialize the event function to ping, we will be the pinger ∗)

  There is not user action, the arrow do not interact with the user

  type user action = None action
144                                                    CHAPTER 26. THE PING-PONG TUTORIAL

26.5.2    Pretty-printers
  print user feedback formater user feedback does what is name suggest

  let print user feedback ppf feedback =
     match feedback with
       | Init → Format.fprintf ppf "%s" "Init"
       | Init ping x → Format.fprintf ppf "%s" "Init ping ( SOMEONE )"

  print user action formater user action does almost nothing

  let print user action ppf action = Format.fprintf ppf "%s" "None action"




26.5.3    Simulator Multiplexer interfaces
  init my address sets up the node

  let init address =
     if ( address = 0 ) then
        (∗ We are the root, simply Init ∗)
        Init
     else
        (∗ We are one of the pingers ∗)
        Init ping ( Unix .ADDR INET ( (Unix .inet addr of string "10.0.0.0" ) , 40000 ))

  user interface timer address user action does nothing here

  let user interface time address user action =
     None

end


26.6     Module Simulation properties
module SimulationProperties =
struct
   let network size = 2
   let end time = 100
   let slow = false
   let latency     = 1. + . Random.float 5.
end


26.7     Module Pingpong modelchecking user
module ModelcheckingUser =
struct
26.8. MODULE MODELCHECKING PROPERTIES                                                         145

26.7.1    Type definitions
  user feedback are events sent to the arrow
  type user feedback =
    | Init (∗ Initialize the arrow, we will be ping ∗)
    | Init ping of Unix .sockaddr (∗ Initialize the arrow to ping, we will be the pinger ∗)
  There is no user action, the event function do not interact with the user
  type user action = None action



26.7.2    Pretty-printers
  print user feedback formater user feedback does what is name suggest
  let print user feedback ppf feedback =
     match feedback with
       | Init → Format.fprintf ppf "%s" "Init"
       | Init ping x → Format.fprintf ppf "%s" "Init ping ( SOMEONE )"
  print user action formater user action does almost nothing
  let print user action ppf action = Format.fprintf ppf "%s" "None action"



26.7.3    Simulator Multiplexer interfaces
  init my address sets up the node
  let init address =
     if ( address = 0 ) then
        (∗ We are the root, simply Init ∗)
        Init
     else
        (∗ We are one of the pingers ∗)
        Init ping ( Unix .ADDR INET ( (Unix .inet addr of string "10.0.0.0" ) , 40000 ))
  user interface timer address user action does nothing here
  let user interface time address user action =
     None
end


26.8      Module Modelchecking properties
module ModelcheckingProperties =
struct
   let network size = 11
   let rand x = 0. (∗ I have randomly chosen 0 ∗)
   let printer s = ()
end
146                                                      CHAPTER 26. THE PING-PONG TUTORIAL

26.9       Module Property
module EF = Event function

module Property
   ( NetworkMap : Map.S ) =
struct

 module Timer = Modelchecker timer .Timer ( Pingpong timers.Timers )
 module User = Pingpong modelchecking user .ModelcheckingUser
 module Network =
  struct
     include ( Network interface types.NetworkInterfaceTypes ( Pingpong messages ) )
     let network interface   = failwith "Property: call to network interface"
  end

 module Peer = Modelchecker peer .Make
  ( Pingpong modelchecking user .ModelcheckingUser )
  ( Timer )
  ( Pingpong messages )

  open   Timer
  open   User
  open   Network
  open   Peer

  open Pingpong messages

  type property =
    | Safety
    | Liveness
    | Safety partial
    | Bounded safety of int

  let kind of property = Safety partial

  let forall peer p network =
     try
        ignore (
           NetworkMap.iter
             ( fun addr peer →
                  if ¬ ( p addr peer ) then
                     raise Not found ;
             )
             network );
        true
     with
        | Not found → false

  let exists peer p network =
     ¬ (forall peer (fun key peer → ¬ (p key peer )) network )
26.9. MODULE PROPERTY                                                                147

  exception Found
  let property network =
     let counter ended event function =
        let repr counter = List.assoc "counter" (EF .get states event function) in
        let value counter = ( Obj .obj repr counter : int ) in
           value counter = 4
     in
     let pending ping or pong pending network =
        try
           ignore (List.find
                      (fun msg →
                          match msg with
                            | UDP in ( , x ) when x = Ping ∨ x = Pong → true
                            |    → false )
                      pending network );
           true
        with
           | Not found → false
     in
     let pending timer timer queue =
        Timer .TimersQueue.size queue timer queue > 0
     in
     let pending ping or pong or timer key peer =
        ignore( counter ended peer .process );
        ignore( pending timer peer .timer queue );
        ( pending ping or pong peer .pending network ) ∨
           ( pending timer peer .timer queue ) ∨
           ( counter ended peer .process )
     in
        exists peer pending ping or pong or timer network
end
148   CHAPTER 26. THE PING-PONG TUTORIAL
Chapter 27

The Chord Protocol

27.1      Module Hashing
open Nat
open Big int




27.1.1     Type definition
Node Identifiers are Big integers:

type id = big int




27.1.2     Pretty printing

let print id ppf id =
   Format.fprintf ppf "@[%s@]" (string of big int id )




27.1.3     Hashing space definition
Space size : Here, we use MD5 which generate strings of 128 bits

let m = 32

We work modulo max id defined by:

let max id = power int positive int 2 m

big int of hexa string string transforms string into a big integer, i.e. an ID.

                                                    149
150                                                               CHAPTER 27. THE CHORD PROTOCOL

let big int of hexa string string =
   let string length = String.length string in
   let rec big int of hexa string pos string acc =
      match pos with
         | x when x = string length → acc
         |    →
              let char code = Char .code ( Char .lowercase string.[pos] ) in
              let value =
                 let alpha code = char code − Char .code ’a’ in
                    if ( alpha code ≥ 0 ) then
                       10 + alpha code
                    else
                       char code − Char .code ’0’
              in
              let prod =
                 add int big int
                    value
                    (mult int big int 16 acc)
              in
                 big int of hexa string (pos + 1) string prod
   in
      big int of hexa string 0 string (big int of int 0)
hash string returns a Chord Identifier
let hash s =
   let hexa string = Digest.to hex (Digest.string s) in
      mod big int (big int of hexa string hexa string) max id



27.1.4     Comparaison operators
is in circular interval id lower bound upper bound returns true if id is between lower bound and upper bound
on a ring of size max id .
let is in circular interval x bound1 bound2 =
   if ( eq big int bound1 bound2 ) then
      (∗ We consider the whole ring : ∗)
      true
   else if ( le big int bound1 bound2 ) then
      (∗ 0 ∈ [bound1, bound2] ∗)
      ( le big int bound1 x ) ∧ ( le big int x bound2 )
   else
      (∗ 0 ∈ [bound1, bound2] ∗)
      ( le big int bound1 x ) ∨ ( le big int x bound2 )
is in open ended interval id lower bound upper bound returns true if is in circular interval id lower bound upper bound
and id is not the upper bound
let is in open ended interval x bound1 bound2 =
   ( ¬ ( eq big int x bound2 ) ) ∧ ( is in circular interval x bound1 bound2 )
is lower or equal x y returns true if x ¡= y. Funny, isn’t it ?
27.2. MODULE NODE                                                                       151

let is lower or equal = le big int
compare x y returns 0 if x = y, c > 0 if x > y and c < 0 if x < y
let compare = compare big int
id1 = | id2 returns true if id1 = id2
let (= |) x y = eq big int x y
id1 <= | id2 returns true if id1 ¡= id2
let (<= |) x y = le big int x y
add 1 id returns id + 1
let add 1 id = add int big int 1 id



27.1.5     Computation operator(s)
add 2 k x k computes 2ˆk + x mod (2ˆm).
let add 2 k x k =
   mod big int
     (add big int
        (power int positive int 2 k )
        x
     )
     max id


27.2      Module Node
27.2.1     Types definitions
id is a shortcut for Chord Identifier
type id = Hashing.id
node description, passed around the network
type node =
     {
       ip : Unix .inet addr ; (∗ Node IP address ∗)
       id : id ; (∗ Node Chord ID ∗)
       proximity : float ; (∗ For optimizing the overlay toward closest nodes ∗)
     }



27.2.2     Pretty-printers
print node formatter node prints the IP address on a given node
let print node ppf node = Format.fprintf ppf "%s" (Unix .string of inet addr node.ip)
verbose print node formatter node prints the complete set of informations about node
152                                                            CHAPTER 27. THE CHORD PROTOCOL

let verbose print node ppf node =
   Format.fprintf
     ppf
     "@[{ @[ip :%s@] ; @[id : %a@] ; @[proximity : %s@]@}@]"
     (Unix .string of inet addr node.ip)
     Hashing.print id node.id
     (string of float node.proximity)



27.2.3     Methods on Node type

let get id node = node.id
let compare nodes n1 n2 =
   let proximity cmp = compare n1 .proximity n2 .proximity in
      if (proximity cmp = 0) then
         Hashing.compare n1 .id n2 .id
      else
         proximity cmp
let make empty node () =
   {
     ip = Unix .inet addr of string "127.0.0.1" ;
     id = Big int.big int of int 0 ;
     proximity = 0. ;
   }
let make node ip =
   {
     ip = ip ;
     id = Hashing.hash (Unix .string of inet addr ip) ;
     proximity = 1000.
   }


27.3      Module Successors
open Hashing



27.3.1     Type definition
successors defines the list of successors one node have over the ring.
type successors =
     {
       max size : int ; (∗ Maximum number of neighbours ∗)
       current size : int ; (∗ Current number of neighbours ∗)
       my node : Node.node ; (∗ Owner node ∗)
       nodes : Node.node list (∗ Successors ∗)
     }
27.3. MODULE SUCCESSORS                                                                      153




27.3.2    Printer
let print list nodes ppf l =
   let rec print list nodes ppf l =
      match l with
         | [ ] → Format.fprintf ppf "%s" ""
         | h :: q →
               Format.fprintf
                 ppf
                 "%a@ ;@ %a"
                 Node.print node h
                 print list nodes q
   in
      Format.fprintf ppf "@[[ %a ]@]" print list nodes l
let print successors ppf successors =
   Format.fprintf
     ppf
     "@[{ max size :@ %d@ ;@ current size :@ %d@ ;@ my node :@ %a@ ;@ nodes :@ %a }@]"
     successors.max size
     successors.current size
     Node.print node successors.my node
     print list nodes successors.nodes



27.3.3    Constructors
create empty max size creates an empty list of successors, bounded by max size
    Used as a place-holder only.
let create empty max size =
   {
     my node = Node.make empty node () ;
     nodes = [ ] ;
     max size = max size ;
     current size = 0 ;
   }
make empty my node max size creates an empty list of successors, bounded by max size and for node
my node
let make empty my node max size =
   {
     max size = max size ;
     current size = 0 ;
     my node = my node ;
     nodes = [ ]
   }
154                                                                CHAPTER 27. THE CHORD PROTOCOL

27.3.4     Accessor
get first successor successors returns my node’s direct successor.
let get first successor successors =
   match successors.nodes with
     | [ ] → None
     | h :: q → Some h



27.3.5     Combinator
fold left f x successors applies f (... (f (f x successors[1]) successors[2]) ...) successors[n].
let fold left f x successors =
   let successors list = successors.nodes in
      List.fold left f x successors list



27.3.6     Insertion & Merge
insert successors node inserts a node in the list of successors.
let insert successors node =
   let rec cut list after k k l =
      match k with
         | 0 → []
         |    →
              match l with
                 | [] → []
                 | h :: q →
                        h :: cut list after k (k − 1) q
   in
   let rec copy without last successors =
      match successors with
         | []
         |    :: [ ] →
              []
         | h :: q →
              h :: copy without last q
   in
   let rec insert previous node id successors =
      match successors with
         | [] →
              if ( previous node id = | node.Node.id ) then
                 [] , []
              else
                 [ ] , [ node ]
         | (h :: q) as l →
              if ( previous node id = | node.Node.id ) then
                 l , []
27.4. MODULE FINGER TABLE                                                                                 155

           else if ( Hashing.is in open ended interval node.Node.id previous node id h.Node.id ) then
              [ node ] , successors
           else
              let legal tail , after insertion tail = insert h.Node.id q in
                 h :: legal tail , after insertion tail
  in
  let legal tail , after insertion tail = insert (Hashing.add 1 successors.my node.Node.id ) successors.nodes in
  let length legal tail = List.length legal tail in
  let cutted after insertion tail = cut list after k (successors.max size − length legal tail ) after insertion tail in
  let nodes = List.append legal tail cutted after insertion tail in
     {
        max size = successors.max size ;
        current size = List.length nodes ;
        my node = successors.my node ;
        nodes = nodes
     }
merge my successors other successors merges my successors list with someone else other successors
let merge successors new successors =
   let rec merge successors nodes =
      match nodes with
         | [ ] → successors
         | h :: q →
               merge (insert successors h) q
   in
      merge successors new successors.nodes



27.3.7    Remove
remove successors node removes the given node from the successors table.
let remove successors node =
   let rec remove previous node successors =
      match successors with
         | [] → []
         | h :: q →
              let compare node h = Hashing.compare node.Node.id h.Node.id in
                 if ( compare node h = 0 ) then
                    (∗ node.id = h.id ∗)
                    q
                 else
                    h :: remove h q
   in
   let new nodes = remove successors.my node successors.nodes in
      { successors with nodes = new nodes ; current size = List.length new nodes }


27.4      Module Finger table
open Hashing
156                                                              CHAPTER 27. THE CHORD PROTOCOL

Finger table module



27.4.1     Types definition
interval indicator is an indicator function, return true if id is in the given interval.
type interval indicator = Hashing.id → bool
finger is a list containing node option, with intervals determined by interval indicator .
   interval indicator is computed at finger’s initialization.
type finger =
  | Nil
  | Cons of ( interval indicator × Node.node option × finger )
finger table is everything we need to operate on fingers
type finger table =
     {
       my node : Node.node ; (∗* The owner of the finger table ∗)
       finger : finger (∗* The fingers ∗)
     }



27.4.2     Pretty-printing

let print finger ppf finger =
   let rec print finger ppf (i , finger ) =
      match finger with
         | Nil →
             Format.fprintf ppf ""
         | Cons ( , Some node , finger ) →
             Format.fprintf ppf "@[@ %d :@ %a@ @]@ %a" i Node.print node node print finger ((i +1), finger );
         | Cons ( , None , finger ) →
             Format.fprintf ppf "@[@ %d :@ (None)@ @]@ %a" i print finger ((i + 1), finger );
   in
      print finger ppf (0, finger )
let print finger table ppf finger =
   Format.fprintf
     ppf
     "@[{@ @[my node : @ %a@ ;@]@ @[@ finger :@ %a@ ; @]}@]@."
     Node.print node finger .my node
     print finger finger .finger



27.4.3     Instanciation functions
create empty () creates an empty finger table.
    To use only as a place-holder.
27.4. MODULE FINGER TABLE                                                                          157

let create empty () =
   {
     my node = Node.make empty node () ;
     finger = Nil
   }
make finger my node creates a finger table owned by my node
let make finger my node =
   let id = my node.Node.id in
   let rec create m =
      match m with
         | x when x = Hashing.m →
              Nil
         |    →
              let sub finger = create (m + 1) in
              let interval min bound = Hashing.add 2 k id m in
              let interval max bound = Hashing.add 2 k id (m + 1) in
              let interval indicator = (fun x → Hashing.is in open ended interval x interval min bound interval max boun
                 Cons ( interval indicator , None , sub finger )
   in
      {
         my node = my node ;
         finger = create 0
      }



27.4.4     Insertion function
Insert hits nil might be raised by insert. Should never happen.
exception Insert hits nil
insert node finger table inserts a node into the finger table, if possible.
let insert finger table node =
   let rec insert node id finger =
      match finger with
         | Nil →
              (∗ Node id ≥ myself .id + ring size ! ∗)
              raise Insert hits nil
         | ( Cons ( indicator , old node , sub finger ) as finger node ) when indicator node id →
              (∗ This node must be inserted here ∗)
           Now, check whether it is optimal to install it or not :
           begin
             match old node with
                | None →
                    (∗ There was nobody : ∗)
                    Cons ( indicator , Some node , sub finger )
                | Some old node →
                    if ( Node.compare nodes old node node ≤ 0 ) then
158                                                           CHAPTER 27. THE CHORD PROTOCOL

                         (∗ Old node ≤ node , replace it : ∗)
                         Cons ( indicator , Some node , sub finger )
                      else
                         (∗ Old node > node , keep it : ∗)
                         finger node
             end
         | Cons ( indicator , old node , sub finger ) →
             (∗ According to previous pattern-matching, we have to go on : ∗)
             let sub finger = insert node id sub finger in
                Cons ( indicator , old node , sub finger )
  in
       if ( node.Node.id = | finger table.my node.Node.id ) then
          finger table
       else
          let finger = insert node.Node.id finger table.finger in
             {
               my node = finger table.my node ;
               finger = finger
             }



27.4.5       Find successor
Successor is myself is raised by go to first present in find successor when we hit Nil of the finger table.
This means that we do not know any successor other than us.
   Always caught by find successor .
exception Successor is myself
Find successor hits nil might be raised by go to domain of in find successor . This should never happen
because it means that the searched id do not belongs to the ring.
exception Find successor hits nil
find successor id finger table finds the first successor of the Chord id in the finger table.
let find successor node id finger table =
  Look for the first node present in the following finger :
  let rec go to first present finger =
     match finger with
        | Nil →
            (∗ Nobody in the whole ring until us ∗)
            raise Successor is myself
        | Cons ( , Some node , ) →
            (∗ We have found someone, take it : ∗)
            node
        | Cons ( , None , finger ) →
            (∗ Not here... go on : ∗)
            go to first present finger
  in
  Go to the interval where the id has its place :
27.4. MODULE FINGER TABLE                                                                              159

   let rec go to domain of node id finger =
      match finger with
         | Nil →
             (∗ This means that node id > myself .id + size of the ring ! ∗)
             raise Find successor hits nil
         | Cons ( indicator , node , sub finger ) →
             match indicator node id with
               | true →
                    (∗ We have found the right interval : ∗)
                    begin
                       match node with
                         | Some node when ( (¬ (node.Node.id = | node id ) ) ∧ node.Node.id <=
| node id ) →
                             (∗ The node in this interval precedes the node id , we have to go further : ∗)
                             go to first present sub finger
                         |   →
                             (∗ Otherwise, search the node from here : ∗)
                             go to first present finger
                    end
               | false →
                    (∗ We have to go on : ∗)
                    go to domain of node id sub finger
   in
      try
         go to domain of node id finger table.finger
      with
         | Successor is myself → finger table.my node




27.4.6    Find immediate predecessor
Key must be here is raised when we hit the interval where the node owning the key should be but isn’t.
Thus, we have to go back. All previous recursive calls which could provide a node have a harness to catch
it and return the concerned node.
    Always caught by find immediate predecessor .

exception Key must be here

Find immediate predecessor hits nil is raised when the searched key is my own id . This should never
happen thanks to a comparaison before the recursive lookup.

exception Find immediate predecessor hits nil

find immediate predecessor key finger finds the closest preceding node in finger for key.

let find immediate predecessor key id finger table =
   let rec find immediate predecessor finger =
      match finger with
         | Nil →
             (∗ Their is only one possibility to be here : node id = my node.id , this should have been
160                                                              CHAPTER 27. THE CHORD PROTOCOL

caught before going there ∗)
           raise Find immediate predecessor hits nil
        | Cons ( indicator , node , ) when indicator key id →
             begin
                match node with
                  | Some node →
                      (∗ Ok, there is a node in the right interval ∗)
                        if ( node.Node.id <= | key id ) then
                           (∗ And this node precedes the key : ∗)
                           node
                        else
                           (∗ Send a signal to the preceding level : ∗)
                           raise Key must be here
                    | None →
                        (∗ Send a signal to the preceding level : ∗)
                        raise Key must be here
               end
           | Cons ( , None , finger ) →
               (∗ In any case, we can’t handle the exception so let it flows : ∗)
               find immediate predecessor finger
           | Cons ( , Some node , finger ) →
               (∗ We are not on the right interval but we might be the preceding node : ∗)
               try
                  find immediate predecessor finger
               with
                  | Key must be here → node
  in
       if ( finger table.my node.Node.id = | key id ) then
          (∗ We are looking for ourself : ∗)
          finger table.my node
       else
          (∗ Search in the finger table : ∗)
             find immediate predecessor finger table.finger



27.4.7       Remove a node from the finger table
remove node finger removes the node of finger
let remove node finger table =
   let node id = node.Node.id in
   let rec remove finger =
      match finger with
         | Nil →
             (∗ And 109 CPU cycles in less... ∗)
             Nil
         | Cons ( indicator , Some current node , finger ) when indicator node id →
             (∗ The node should be here : ∗)
             if ( current node.Node.id = | node id ) then
27.5. MODULE COMMAND TYPE                                                                            161

              (∗ Remove it : ∗)
              Cons ( indicator , None , finger )
           else
              (∗ That’s ok, it cannot be further : ∗)
              Cons ( indicator , Some current node , finger )
       | Cons ( indicator , current node , finger ) →
           (∗ According to pattern matching, we have to go further : ∗)
           let finger = remove finger in
              Cons ( indicator , current node , finger )
  in
  let finger = remove finger table.finger in
     {
       my node = finger table.my node ;
       finger = finger
     }


27.5      Module Command type
open Node
 In this file, we have defined the types which are exchanged over the network, with the user and the timer.
We merge all these types into the command type.
    Note that we could have used polymorphic variants but at the expense of the clarity of type-checker
errors.
Count the number of hops during a recursive query. For statistics.
type hop counter = int
message corresponds to every messages which can be sent/received over the network.
type network command =
   | Recursive query of ( id × hop counter × network command )
        (∗ Any kind of recursive look-up query over the DHT, the end-call command is the third element of
the tuple ∗)
   | Find peer for key of ( hop counter × node × id )
        (∗ When joining, find the successor of a given node ∗)
  | Key is at of ( id × hop counter × node )
       (∗ When a key look-up achieved its goal, gives the location ∗)
  | Find successors for of ( node )
       (∗ When node is looking for successors ∗)
  | Your successors are of ( Successors.successors )
       (∗ When someone gives us our successors ∗)
  | Who is your predecessor of ( node )
       (∗ When node asked its probably successor to know who is its predecessor ∗)
  | Predecessor of x is y of ( node × node )
       (∗ When x announce its predecessor y to a given node ∗)
  | Notify predecessor of ( node )
       (∗ When a node has found its place, it announces at node that it is its predecessor ∗)
  | Find finger for of ( id × node )
       (∗ To populate node fingers table, look for id ∗)
  | Finger entry is of ( id × node )
162                                                            CHAPTER 27. THE CHORD PROTOCOL

       (∗ To help someone to populate its fingers table, give it node corresponding to an id ∗)
user command corresponds to every events that the user can send to the arrow
type user command =
  | Bootstrap on x in t of ( node × node × float )
       (∗ Delayed bootstrap on x ∗)
  | Bootstrap on of ( node × node )
       (∗ Bootstrap on a given node ∗)
  | Bootstrap alone of node
       (∗ Bootstrap alone ∗)
  | Find key of id
       (∗ Search key id ∗)
  | Schedule test of float
       (∗ Ask for scheduling a test of a given period ∗)
timer command corresponds to every events that can be signaled by timeout
type timer command =
  | Do stabilize
       (∗ Launch a Stabilize operation ∗)
  | Do fix fingers
       (∗ Launch a Fix Finger operation ∗)
  | Ask user for key search
       (∗ Time to ask for a key-look-up ∗)
  | Launch bootstraping of ( node × node )
       (∗ End of a delayed bootstrap, launch it ∗)
  | Drop fingers
       (∗ For statistics, print on the standard output the finger table ∗)
command merges the previous types under one, include a NOP command
type command =
  | User of user command
  | Network of network command
  | Timer of timer command
  | No command


27.6      Module Command type printers
open Command type
print network command formatter message does what it is intended to. :-)
let rec print network command ppf m =
   match m with
      | Recursive query ( id , hop counter , command ) →
          Format.fprintf
             ppf
             "@[Recursive query (@[ %a , %d , %a @])"
             Hashing.print id id
             hop counter
             print network command command
27.6. MODULE COMMAND TYPE PRINTERS                        163

   | Find peer for key ( hop counter , node , id ) →
       Format.fprintf
          ppf
          "@[Find peer for key (@[ %a , %a @])@]"
          Node.print node node
          Hashing.print id id
   | Key is at ( id , hop counter , node ) →
       Format.fprintf
          ppf
          "@[Key is at (@[ %a , %d , %a @])@]"
          Hashing.print id id
          hop counter
          Node.print node node
   | Find successors for node →
       Format.fprintf
          ppf
          "@[Find successors for (@[ %a @])@]"
          Node.print node node
   | Your successors are successors →
       Format.fprintf
          ppf
          "@[Your successors are (@[ %a @])@]"
          Successors.print successors successors
   | Who is your predecessor ( node ) →
       Format.fprintf
          ppf
          "@[Who is your predecessor (@[ %a @])@]"
          Node.print node node
   | Predecessor of x is y ( node , pred node ) →
       Format.fprintf
          ppf
          "@[Predecessor of x is y (@[ %a@ ,@ %a @])@]"
          Node.print node node
          Node.print node pred node
   | Notify predecessor node →
       Format.fprintf
          ppf
          "@[Notify predecessor (@[ %a @])@]"
          Node.print node node
   | Find finger for ( id , node ) →
       Format.fprintf
          ppf
          "@[Find finger for (@[ %a , %a @])@]"
          Hashing.print id id
          Node.print node node
   | Finger entry is ( id , node ) →
       Format.fprintf
          ppf
          "@[Finger entry is (@[ %a , %a @])@]"
164                                                   CHAPTER 27. THE CHORD PROTOCOL

            Hashing.print id id
            Node.print node node
print user command formatter user command
let print user command ppf m =
   match m with
     | Bootstrap on x in t ( my node , boot node , delay ) →
          Format.fprintf
            ppf
            "@[Bootstrap on x in t (@[ %a@ ,@ %a@ ,@ %f @])@]"
            Node.print node my node
            Node.print node boot node
            delay
     | Bootstrap on ( my node , boot node ) →
          Format.fprintf
            ppf
            "@[Bootstrap on (@[ %a@ ,@ %a @])@]"
            Node.print node my node
            Node.print node boot node;
     | Bootstrap alone ( my node ) →
          Format.fprintf
            ppf
            "@[Bootstrap alone (@[ %a @]) @]"
            Node.print node my node
     | Find key ( id ) →
            Format.fprintf
              ppf
              "@[Find peer for key (@[ %a @])@]"
              Hashing.print id id
        | Schedule test ( t ) →
            Format.fprintf
              ppf
              "@[Schedule test (@[ %f @])@]"
              t
print timer command formatter timer command
 let print timer command ppf t =
    match t with
      | Do stabilize → Format.fprintf ppf "%s" "Do stabilize"
      | Do fix fingers → Format.fprintf ppf "%s" "Do fix fingers"
      | Ask user for key search → Format.fprintf ppf "%s" "Ask user for key search"
      | Launch bootstraping ( , ) → Format.fprintf ppf "%s" "Launch bootstraping ( ... , ... )"
      | Drop fingers → Format.fprintf ppf "%s" "Drop fingers"


27.7    Module Chord network messages
open Node
type message = Command type.network command
27.8. MODULE CHORD SIMULATED USER                                                                 165

let print message = Command type printers.print network command
let signature of message message = Marshal .to string message [ ]
let to string message message = Marshal .to string message [ ]
let from string message string = ( Marshal .from string string 0 : Command type.network command )


27.8      Module Chord simulated user
open Command type



27.8.1    Simulation parameters
Time between two random look-up query
let inter test time = 50.
module SimulatedUser =
struct



27.8.2    Types definitions
  Get the user feedback from the universal set of feedback
  type user feedback = user command
  Define the possible user action
  type user action =
    | Key found of Hashing.id × int × Node.node (∗ We are signaled that a key has been found ∗)
    | Joined (∗ We are signaled that we are joined ∗)
    | Ask for key (∗ We are signaled that the system want to be asked a key look-up ∗)



27.8.3    Pretty-printing
  Print the user feedback, rely on the already defined function
  let print user feedback = Command type printers.print user command
  Print the user action
  let print user action ppf m =
     match m with
       | Key found ( key , hop counter , node ) →
              Format.fprintf
                ppf
                "@[Key found (@[ %a , %d , %a @])@]"
                Hashing.print id key
                hop counter
                Node.print node node
       | Joined → Format.fprintf ppf "%s" "Joined"
       | Ask for key → Format.fprintf ppf "%s" "Ask for key"
166                                                          CHAPTER 27. THE CHORD PROTOCOL




27.8.4    Interface to the multiplexer
  user interface for the Simulator Multiplexer :
  let user interface addr time action =
     Format.fprintf Format.std formatter "[%d] %d : %a@." time addr print user action action;
     flush stdout;
     match action with
       | Key found ( ) →
            (∗ A key look-up has succeeded, do nothing ∗)
            None
       | Joined →
            (∗ We are Joined, schedule look-up testing : ∗)
              Some (Schedule test inter test time)
       | Ask for key →
            (∗ We are asked a key, generate it and send it : ∗)
            let key = Hashing.hash (string of float (Unix .gettimeofday ())) in
               Some ( Find key key )
  init node id is used by the Simulator Multiplexer to initialize the overlay on the node node id
  let init i =
     (∗ Get a bootstraping node : ∗)
     let root = Node.make node (Int to inet.inet addr of int 0) in
        if ( i = 0 ) then
           begin
              (∗ We are the bootstraping node : ∗)
              Format.print newline ();
              Format.fprintf Format.std formatter "Bootstrap node %a@." Node.verbose print node root;
              Bootstrap alone root
           end
        else
           (∗ We are an other node, bootstrap on Root in node id × 20 cycles : ∗)
           let node = Node.make node (Int to inet.inet addr of int i ) in
              Format.fprintf Format.std formatter "Bootstrap node %a@." Node.verbose print node node ;
              Bootstrap on x in t ( node , root , (float of int i ) ∗ .20.)
end


27.9      Module Chord timers
module Timers =
struct



27.9.1    Type definition
  timers is built using the universal definition
27.10. MODULE CHORD                                                                    167

  type timers = Command type.timer command




27.9.2      Pretty-printing
  print timers is simply imported from the universal definition

  let print timers = Command type printers.print timer command

  let signature of command timer =
     match timer with
        | Command type.Do stabilize → "do stabilize"
        | Command type.Do fix fingers → "do fix fingers"
        | Command type.Ask user for key search → "ask user for key search"
        | Command type.Launch bootstraping ( node1 , node2 ) → "launch bootstraping"
        | Command type.Drop fingers → "drop fingers"

end



27.10       Module Chord
Connections to ModelNet/real use :

module Timer = Network timer .Timer ( Chord timers.Timers )
module Launcher = Network launcher .Launcher
  ( Chord modelnet user .User )
  ( Timer )
  ( Chord network messages )
open Chord modelnet user .User

module EF = Event function

let =
   EF .set profiling true

open   Chord timers.Timers
open   Timer
open   Launcher
open   Launcher .Network
open   EF

open Node

open Hashing
open Command type
168                                                        CHAPTER 27. THE CHORD PROTOCOL

27.10.1      Parameters initialization

let   fix fingers period = 1.
let   stabilize period = 1.
let   dump fingers period = 2.
let   max no successors = 16
let   port = 20203
let   transport = UDP




27.10.2      Basic functions

let make sockaddr of ip ip = Unix .ADDR INET ( ip , port )
let send out destination msg =
   Network out
     (
       Send
         (
           (make sockaddr of ip destination.ip) ,
           transport ,
           msg
         )
     )

let empty node = make empty node ()




27.10.3      Interpret input
Dispatch queries :

let filter query =
   match query with
     | ‘Network in x → Left ( Left x )
     | ‘Timer in x → Left ( Right x )
     | ‘User in ( x : Chord simulated user .SimulatedUser .user feedback ) → Right x
let arr filter () = pure ˜name :"filter" filter




Network

Marshal input
27.10. MODULE CHORD                                                                          169

let marshal network queries query =
   match query with
     | UDP in ( peer , command ) →
         Network ( command )
     | Listening on ( )
     | Sent ( ) →
         (∗ Do not check when everything is right ∗)
         No command
     |   →
         Printf .printf "Unexpected Network query.\n";
         No command
Print input debug
let print network queries (print , query) =
   match query with
     | Network command →
          Format.fprintf
            Format.str formatter
            "IN NET : @[%a@]@."
            Command type printers.print network command command ;
          print (Format.flush str formatter ());
          query
     |    → query
let arr print network queries = arr print ˜name :"print network queries" print network queries
Interpret network event-function!
let arr interpret network queries =
   (pure ˜name :"marshall network queries" marshal network queries)

(∗


User
∗)
Print user input debug :
let print user queries ( print , query ) =
   match query with
     | User user query →
          Format.fprintf
            Format.str formatter
            "IN USER : @[%a@]@."
            Command type printers.print user command user query;
          print (Format.flush str formatter ());
          query
     |    → query
let arr print user queries = arr print ˜name :"print user queries" print user queries
Interpret user input
170                                                        CHAPTER 27. THE CHORD PROTOCOL

let interpret user queries query =
   match query with
      | Bootstrap on ( )
      | Bootstrap on x in t ( )
      | Bootstrap alone ( )
      | Find key ( )
      | Schedule test ( ) →
          User query
let arr interpret user queries =
   (pure ˜name :"interpret user queries" interpret user queries)

(∗


Timer
∗)

Print timer input

let print timer queries ( print , query ) =
   match query with
     | Timer timer query →
          Format.fprintf
            Format.str formatter
            "IN TIMER : @[%a@]@."
            Command type printers.print timer command timer query;
          print (Format.flush str formatter ());
          query
     |    → query

Interpret timer input

let interpret timer queries query =
   match query with
      | Timeout ( { command = Do stabilize } as query )
      | Timeout ( { command = Do fix fingers } as query )
      | Timeout ( { command = Ask user for key search } as query )
      | Timeout ( { command = Drop fingers } as query ) →
          Timer query.command
      | Timeout { command = Launch bootstraping ( myself , boot node ) } → User ( Bootstrap on ( myself , boot node ) )
      | Timer killed
      | Timer up     →
          No command
let arr interpret timer queries =
   ( pure ˜name :"interpret timer queries" interpret timer queries )




Final wiring
Interpret input module :
27.10. MODULE CHORD                                                                           171

let arr interpret () =
   arr filter ()
   >>> ( arr interpret network queries
          ——— arr interpret timer queries
            ——— arr interpret user queries )




27.10.4    Mainteners

let pair result q = ( q , q )
let arr pair result () = pure ˜name :"pair result" pair result




Maintain myself


let myself maintener ( command , myself ) =
   match command with
     | User Bootstrap on x in t ( new myself , , )
     | User Bootstrap alone ( new myself )
     | User Bootstrap on ( new myself , ) → new myself
     |    → myself

let arr myself maintener =
   dloop
     empty node
     ( ( pure ˜name :"myself maintener" myself maintener ) >>> ( arr pair result () ) )




Maintain the bootnode


let bootnode maintener ( command , bootnode ) =
   match command with
     | User Bootstrap on x in t ( , bootnode , )
     | User Bootstrap alone ( bootnode )
     | User Bootstrap on ( , bootnode ) → bootnode
     |    → bootnode

let arr bootnode maintener =
   dloop
     empty node
     ( ( pure ˜name :"bootnode maintener" bootnode maintener ) >>> ( arr pair result () ) )
172                                                          CHAPTER 27. THE CHORD PROTOCOL

Maintain the predecessor

type predecessor maintener state =
     {
       myself : Node.node ;
       predecessor : Node.node option
     }
let predecessor maintener ( command , state ) =
   match command with
        (∗ Init : ∗)
      | User Bootstrap on ( myself , )
      | User Bootstrap on x in t ( myself , , ) →
          let state = { myself = myself ; predecessor = None } in
             state.predecessor , state
      | User Bootstrap alone ( myself ) →
          let state = { myself = myself ; predecessor = Some myself } in
             state.predecessor , state
          (∗ Regular use : ∗)
      | Network Notify predecessor probable predecessor →
          let predecessor =
             match state.predecessor with
                | None → probable predecessor
                | Some my predecessor →
                     if Hashing.is in open ended interval probable predecessor .id my predecessor .id state.myself .id then
                        probable predecessor
                     else
                        my predecessor
          in
          let state = { state with predecessor = Some predecessor } in
             state.predecessor , state
      |   →
          state.predecessor , state
let arr predecessor maintener = dloop { myself = empty node ; predecessor = None } (pure ˜name :"predecessor maint



Maintain the fingers

let finger table maintener ( command , finger table ) =
   match command with
       (∗ Init : ∗)
     | User Bootstrap on x in t ( myself , bootstrap node , )
     | User Bootstrap on ( myself , bootstrap node ) →
         let finger table = Finger table.make finger myself in
            Finger table.insert finger table bootstrap node
     | User Bootstrap alone ( myself ) →
         Finger table.make finger myself
            (∗ Optimisations : ∗)
     | Network Find finger for ( , node )
27.10. MODULE CHORD                                                                               173

    | Network Key is at ( , , node )
    | Network Notify predecessor ( node )
    | Network Recursive query ( , , Find peer for key ( , node ,          ))
    | Network Recursive query ( , , Find finger for ( , node ) )
        (∗ Regular use : ∗)
    | Network Finger entry is ( , node ) →
        Finger table.insert finger table node
          (∗ Optimisation : ∗)
    | Network Your successors are ( successors ) →
        Successors.fold left Finger table.insert finger table successors
    |   →
        finger table
let arr finger table maintener =
   dloop
     (Finger table.create empty ())
     ( ( pure ˜name :"finger table maintener" finger table maintener ) >>> ( arr pair result () ) )



Maintain the successors

type successors maintener state =
     {
       myself : node ;
       successors : Successors.successors
     }
let successors maintener ( command , state ) =
   match command with
        (∗ Init : ∗)
     | User Bootstrap on x in t ( myself , , )
     | User Bootstrap on ( myself , ) →
          let state = { myself = myself ; successors = Successors.make empty myself max no successors } in
             state.successors , state
     | User Bootstrap alone myself →
          let successors = Successors.make empty myself max no successors in
          let successors = Successors.insert successors myself in
          let state = { myself = myself ; successors = successors } in
             successors , state
          (∗ Regular use : ∗)
     | Network Your successors are ( successors ) →
          let successors = Successors.merge state.successors successors in
             successors , { state with successors = successors }
     | Network Predecessor of x is y ( sender , sender predecessor ) →
          let successors = Successors.insert state.successors sender predecessor in
             successors , { state with successors = successors }
            (∗ Optimisations : ∗)
     | Network Find peer for key ( , node , )
     | Network Key is at ( , , node )
     | Network Who is your predecessor ( node )
174                                                         CHAPTER 27. THE CHORD PROTOCOL

      | Network Notify predecessor ( node )
      | Network Find finger for ( , node )
      | Network Finger entry is ( , node )
      | Network Recursive query ( , , Find peer for key ( , node , ) )
      | Network Recursive query ( , , Find finger for ( , node ) ) →
          let successors = Successors.insert state.successors node in
             successors , { state with successors = successors }
      |   →
          state.successors , state

let arr successors maintener =
   dloop
     { myself = empty node ; successors = Successors.create empty max no successors }
     (pure ˜name :"successors maintener" successors maintener )




Wrap into State


type state =
     {
       command : command ;
       myself : node ;
       predecessor : node option ;
       successors : Successors.successors ;
       finger : Finger table.finger table ;
       bootnode : node ;
     }




Transform tuples into states


let lift to state ( ( ( ( ( q1 , q2 ) , q3 ) , q4 ) , q5 ) , q6 ) =
   {
      command = q1 ;
      myself = q2 ;
      predecessor = q3 ;
      successors = q4 ;
      finger = q5 ;
      bootnode = q6 ;
   }
let arr lift to state = pure ˜name :"lift to state" lift to state
27.10. MODULE CHORD                                                                                    175

Transform recursive calls at end-point

let transform recursive calls state =
   match state.command with
      | Network Recursive query ( id , hop counter , sub query ) →
          (∗ This is a recursive query ∗)
          let successor = Successors.get first successor state.successors in
             begin
             match successor with
               | None → state
               | Some successor →
                    (∗ Our successor is well-defined ∗)
                    if Hashing.is in circular interval id state.myself .id successor .id then
                       (∗ And this query is for us ∗)
                       let sub query =
                          (∗ For statistics, transfer the hop counter for a recursive key look-up ∗)
                          match sub query with
                          | Find peer for key ( , node , id ) → Find peer for key ( hop counter , node , id )
                          |    → sub query
                       in
                          (∗ Extract the sub-query : end of recursive call ∗)
                          { state with command = Network sub query }
                    else
                       (∗ Otherwise, recursive call ∗)
                       state
             end
      |   → state
let arr transform recursive calls = pure ˜name :"transform recursive call" transform recursive calls



For debug, print the state

let state printer (print, state) =
   let predecessor = match state.predecessor with
      | None → "None"
      | Some node →
           ignore(Format.flush str formatter ());
           Format.fprintf Format.str formatter "%a" Node.print node node;
           Format.flush str formatter ();
   in
      Format.fprintf
         Format.str formatter
         "@[myself :@ %a@ ;@ predecessor :@ %s@ ;@ successors :@ %a@ ;@ finger :@ %a@ @]@."
         Node.print node state.myself
         predecessor
         Successors.print successors state.successors
         Finger table.print finger table state.finger ;
      print (Format.flush str formatter ());
      state
176                                                         CHAPTER 27. THE CHORD PROTOCOL

let arr state printer = arr print ˜name :"state printer" state printer



Wrap the state maintenance module

let state maintener =
   (
      ( identity () )
      &&& arr myself maintener
      &&& arr predecessor maintener
      &&& arr successors maintener
      &&& arr finger table maintener
      &&& arr bootnode maintener
   )
   >>> arr lift to state
   >>> arr transform recursive calls




27.10.5     Reactions



For Printing

let print fingers ( print , state ) =
   match state.command with
     | Timer Drop fingers →
          Format.fprintf Format.str formatter "Finger table : %a@." Finger table.print finger table state.finger ;
          print (Format.flush str formatter ());
          flush stdout;
          Do nothing
     |    →
          Do nothing
let arr print fingers = arr print ˜name :"print fingers" print fingers



For user
When a key is found :
let key found state =
   match state.command with
     | Network Key is at ( key , hop counter , node ) → User out( Key found ( key , hop counter , node ) )
     |    → Do nothing
let arr key found = pure ˜name :"key found" key found
Ask for a key search :
27.10. MODULE CHORD                                                                               177

let ask user for key search state =
   match state.command with
     | Timer Ask user for key search →
         User out Ask for key
     |   → Do nothing
let arr ask user for key search = pure ˜name :"ask user for key search" ask user for key search
Signal when we are Joined
type joining state = Is joining | Has joined
let signal joined state (state, joining state) =
   match joining state with
      | Has joined → Do nothing , Has joined
      | Is joining →
           match state.predecessor with
             | None → Do nothing , Is joining
             | Some     → (User out Joined ) , Has joined
let arr joined state = dloop Is joining (pure ˜name :"signal joined state" signal joined state)



For timer
Schedule a periodic test of the overlay :
let schedule test state =
   match state.command with
     | User Schedule test inter test time →
          Timer out
            (Launch timer
               {
                  Timer .delay = inter test time ;
                  Timer .timer type = Periodic ;
                  Timer .command = Ask user for key search
               }
            )
     |    → Do nothing
let arr schedule test = pure ˜name :"schedule test" schedule test
Delay the boostrap later :
let delayed bootstrap state =
   match state.command with
     | User Bootstrap on x in t ( myself , bootstrap node , delay ) →
          Timer out
            (Launch timer
               {
                  Timer .delay = delay ;
                  Timer .timer type = Unique ;
                  Timer .command = Launch bootstraping ( myself , bootstrap node )
               }
            )
178                                                       CHAPTER 27. THE CHORD PROTOCOL

     |   → Do nothing
let arr delayed bootstrap = pure ˜name :"delayed bootstrap" delayed bootstrap
Schedule the Stabilize operations :
let schedule stabilize state =
   match state.command with
     | User Bootstrap on ( )
     | User Bootstrap alone ( ) →
          Timer out
            (Launch timer
               {
                  Timer .delay = stabilize period ;
                  Timer .timer type = Periodic ;
                  Timer .command = Do stabilize
               }
            )
     |    → Do nothing
let arr schedule stabilize = pure ˜name :"schedule stabilize" schedule stabilize
Schedule the Fix fingers operations :
let schedule fix fingers state =
   match state.command with
     | User Bootstrap on ( )
     | User Bootstrap alone ( ) →
          Timer out
            (Launch timer
               {
                 Timer .delay = fix fingers period ;
                 Timer .timer type = Periodic ;
                 Timer .command = Do fix fingers
               }
            )
     |    → Do nothing
let arr schedule fix fingers = pure ˜name :"schedule fix fingers" schedule fix fingers
Schedule the Dump of the fingers :
let schedule dump fingers state =
   match state.command with
     | User Bootstrap on ( )
     | User Bootstrap alone ( ) →
          Timer out
            (Launch timer
               {
                 Timer .delay = dump fingers period ;
                 Timer .timer type = Periodic ;
                 Timer .command = Drop fingers ;
               }
            )
     |    → Do nothing
let arr schedule dump fingers = pure ˜name :"schedule dump fingers" schedule dump fingers
27.10. MODULE CHORD                                                                                         179




For network

Open port for system :

let open port state =
   match state.command with
     | User Bootstrap on ( )
     | User Bootstrap alone ( ) →
         Network out (Listen on ( port , transport ))
     |   → Do nothing
let arr open port = pure ˜name :"open port" open port

React to Fix fingers :

let do fix fingers ( rand , state ) =
   match state.command with
     | Timer Do fix fingers →
         let i = int of float (ceil ( rand ( float of int Hashing.m ) ) ) in
         let key = Hashing.add 2 k state.myself .id i in
            begin
              try
                 let target = Finger table.find immediate predecessor key state.finger in
                    send out target (Recursive query ( key , 0 , Find finger for ( key , state.myself ) ) )
              with
                 | Finger table.Key must be here →
                       let successor = Successors.get first successor state.successors in
                          begin
                            match successor with
                               | None → Do nothing
                               | Some successor →
                                   send out successor (Recursive query ( key , 0 , Find finger for ( key , state.myself ) ) )
                          end
            end
     |   → Do nothing
let arr do fix fingers = arr rand ˜name :"do fix fingers" do fix fingers

React to a Finger research :

let finger help state =
   match state.command with
     | Network Find finger for ( key , sender ) →
         send out sender (Finger entry is ( key , sender ))
     |   → Do nothing
let arr finger help = pure ˜name :"finger help" finger help

Notify our successor of our presence :
180                                                          CHAPTER 27. THE CHORD PROTOCOL

let notify our successor state =
   match state.command with
     | Network Predecessor of x is y ( ) →
          let successor = Successors.get first successor state.successors in
             begin
               match successor with
                  | None → Do nothing
                  | Some successor →
                      send out successor (Notify predecessor state.myself )
             end
     |    → Do nothing
let arr notify our successor = pure ˜name :"notify our successor" notify our successor

React to a predecessor research :

let predecessor help state =
   match state.command with
     | Network Who is your predecessor sender →
          begin
            match state.predecessor with
               | None → Do nothing
               | Some predecessor → send out sender (Predecessor of x is y ( state.myself , predecessor ))
          end
     |    → Do nothing
let arr predecessor help = pure ˜name :"predecessor help" predecessor help

React to a stabilization request :

let stabilize state =
   match state.command with
      | Timer Do stabilize →
           begin
             let successor = Successors.get first successor state.successors in
                match successor with
                  | None → Do nothing
                  | Some successor →
                       send out successor (Who is your predecessor state.myself )
           end
      |    → Do nothing
let arr stabilize = pure ˜name :"stabilize" stabilize

For bootstraping, find successors :

let find successors state =
   match state.command with
     | User Bootstrap on ( , boot node ) →
         send out boot node (Recursive query (state.myself .id , 0 , Find successors for state.myself ) )
     |   → Do nothing
let arr find successors = pure ˜name :"find successors" find successors

On end-point of a Find successors request :
27.10. MODULE CHORD                                                                                           181

let successors help state =
   match state.command with
     | Network Find successors for sender →
          send out sender (Your successors are ( state.successors ) )
     |    → Do nothing
let arr successors help = pure ˜name :"successors help" successors help
On end-point of a Find peer for key :
let peer for key help state =
   match state.command with
     | Network Find peer for key ( hop counter , sender , key ) →
          let successor = Successors.get first successor state.successors in
             begin
               match successor with
                  | None → Do nothing
                  | Some successor →
                      send out sender (Key is at (key , hop counter , successor ))
             end
     |    → Do nothing
let arr peer for key help = pure ˜name :"peer for key help" peer for key help
On a user request for a key :
let launch recursive key lookup state =
   match state.command with
      | User Find key key →
          if ( key = | state.myself .id ) then
             (∗ We are looking for ourself... ∗)
             User out (Key found (key , 0 , state.myself ))
          else
             let successor = Successors.get first successor state.successors in
                begin
                  match successor with
                     | None →
                         (∗ We are not connected to the network, drop the request ∗)
                         Do nothing
                     | Some successor →
                         (∗ We have a successor ∗)
                         if (Hashing.is in circular interval key state.myself .id successor .id ) then
                            begin
                               (∗ Our successor must own the key ∗)
                               User out (Key found (key , 0 , successor ))
                            end
                         else
                            (∗ We have to initiate a recursive key look-up : ∗)
                            try
                               let target = Finger table.find immediate predecessor key state.finger in
                                  (∗ There is a node better informed than we are, relay the recursive query on
it : ∗)
                                  send out target (Recursive query ( key , 0 , (Find peer for key ( 0 , state.myself , key ) ) ) )
                            with
182                                                           CHAPTER 27. THE CHORD PROTOCOL

                           | Finger table.Key must be here →
                               (∗ Our routing table is empty, relay on successor ∗)
                               send out successor (Recursive query ( key , 0 , (Find peer for key ( 0 , state.myself , key )
              end
      |   → Do nothing
let arr launch recursive key lookup = pure ˜name :"launch recursive key lookup" launch recursive key lookup
On a recursive look-up :
let recursive relay (print , state) =
   match state.command with
      | Network Recursive query ( key , hop counter , query ) →
          begin
             try
                let target = Finger table.find immediate predecessor key state.finger in
                   send out target (Recursive query ( key , hop counter + 1 , query ))
             with Finger table.Key must be here →
                let successor = Successors.get first successor state.successors in
                   match successor with
                      | None →
                          Do nothing
                      | Some successor → send out successor (Recursive query ( key , hop counter +
1 , query ) )
          end
      |   → Do nothing
let arr recursive relay = arr print ˜name :"recursive relay" recursive relay



Wrap the reaction module

let arr react =
   arr schedule fix fingers
   &&— arr schedule stabilize
     &&— arr key found
       &&— arr schedule test
          &&— arr ask user for key search
            &&— arr joined state
              &&— arr open port
                &&— arr delayed bootstrap
                  &&— arr do fix fingers
                     &&— arr finger help
                       &&— arr notify our successor
                          &&— arr stabilize
                            &&— arr find successors
                                &&— arr successors help
                                   &&— arr peer for key help
                                      &&— arr launch recursive key lookup
                                          &&— arr recursive relay
                                            &&— arr predecessor help
                                               &&— arr schedule dump fingers
27.11. MODULE CHORD MODELNET USER                                                                  183




27.10.6      Final Wiring
Debug printers :
let printer multiplexer in (print , input) =
   Format.fprintf Format.str formatter "@[IN : %a@]@." Launcher .string of multiplexer in input;
   print (Format.flush str formatter ());
   flush stdout;
   input
let arr printer multiplexer in () = arr print ˜name :"printer multiplexer in" printer multiplexer in
let printer multiplexer out ( print , output ) =
   match output with
      | Do nothing → output
      |   →
          Format.fprintf Format.str formatter "@[OUT : %a@]@." Launcher .string of multiplexer out output;
          print (Format.flush str formatter ());
          flush stdout;
          output
let arr printer multiplexer out () = arr print ˜name :"printer multiplexer in" printer multiplexer out
Chord arrow :
let chord () =
     ( arr interpret () )
     >>> state maintener
   >>> arr react

(∗ Go ! ∗)
let =
   Launcher .launcher ( chord () )


27.11        Module Chord modelnet user
open Command type
N.B.: Some factoring could be done with the Simulator user



27.11.1      Simulation parameters
Time between two random look-up query
let inter test time = 5.
module User =
struct
184                                                          CHAPTER 27. THE CHORD PROTOCOL

27.11.2     Types definitions
  Get the user feedback from the universal set of feedback
  type user feedback = user command
  Define the possible user action
  type user action =
    | Key found of Hashing.id × int × Node.node (∗ We are signaled that a key has been found ∗)
    | Joined (∗ We are signaled that we are joined ∗)
    | Ask for key (∗ We are signaled that the system want to be asked a key look-up ∗)



27.11.3     Pretty-printing
  Print the user feedback, rely on the already defined function
  let print user feedback = Command type printers.print user command
 Print the user action
 let print user action ppf m =
    match m with
      | Key found ( key , hop counter , node ) →
             Format.fprintf
               ppf
               "@[Key found (@[ %a , %d , %a @])@]"
               Hashing.print id key
               hop counter
               Node.print node node
      | Joined → Format.fprintf ppf "%s" "Joined"
      | Ask for key → Format.fprintf ppf "%s" "Ask for key"



27.11.4     Interface to the multiplexer
  user interface for the Network Multiplexer
 let user interface ( channel multiplexer , channel user ) =
    begin
      try
         (∗ The program starts : ∗)
         let my node = Sys.argv .(1) in
         let my node = Node.make node ( Unix .inet addr of string my node ) in
            (∗ Get our IP address from the command line ∗)
            Format.fprintf Format.std formatter "My node : %a@." Node.verbose print node my node;
            begin
              try
                 (∗ Get the IP address of a bootstrap node, if no IP, we are alone ∗)
                 let boot node = Sys.argv .(2) in
                 let boot node = Node.make node ( Unix .inet addr of string boot node ) in
                    (∗ Launch the bootstrap on the given ip : ∗)
27.12. MODULE SIMULATION PROPERTIES                                                                         185

                        Event.sync ( Event.send channel multiplexer (‘User in (Bootstrap on ( my node , boot node ) ) ) )
                 with
                   |      →
                          (∗ Otherwise, bootstrap alone : ∗)
                          Event.sync ( Event.send channel multiplexer (‘User in (Bootstrap alone my node) ) )
               end
        with
          |      →
                 (∗ No IP address given, fails ∗)
                 failwith "Chord : first argument must be my IP address."
      end;
      (∗ Run in normal mode : ∗)
      while true do
        let action = Event.sync ( Event.receive ( channel user ) ) in
           (∗ Got an action from the Arrow :∗)
           Format.fprintf Format.std formatter "[%f] %s : %a@." (Unix .gettimeofday ()) Sys.argv .(1) print user action acti
           flush stdout;
           match action with
              | Key found ( ) →
                  (∗ A key look-up has succeeded, do nothing ∗)
                  ()
              | Joined →
                  (∗ We are Joined, schedule look-up testing : ∗)
                  Event.sync ( Event.send channel multiplexer (‘User in (Schedule test inter test time) ) )
              | Ask for key →
                  (∗ We are asked a key, generate it and send it : ∗)
                  let key = Hashing.hash (string of float (Unix .gettimeofday ())) in
                     Event.sync ( Event.send channel multiplexer (‘User in ( Find key key ) ) )
      done
end


27.12          Module Simulation properties
Define the simulation properties.
   Here, for simplicity, things are hard-coded. But it’s a matter of 3 lines of code to load them from a file.
module SimulationProperties =
struct
   let network size = 10
   let end time = 6 × 500 × 3
   let slow = false
   let latency     = 1.
end
186   CHAPTER 27. THE CHORD PROTOCOL
Chapter 28

Generic Gossip Protocol

28.1       Module Gossip signatures
module type GOSSIP VIEW =
sig
   type t
   val empty : t
   val print view : Format.formatter → t → unit
end

module EF = Event function

module type GOSSIP SPECIFICATION =
sig

  module View : GOSSIP VIEW

  type   input
  type   net input
  type   user input
  type   timer input

  type internal message

  type   net output
  type   user output
  type   timer output
  type   output

  val arr filter : ( input, ( ( net input, user input ) EF .either , timer input ) EF .either ) EF .arrow

  val arr interpret network : ( net input , internal message) EF .arrow
  val arr interpret user : ( user input , internal message) EF .arrow
  val arr interpret timer : ( timer input , internal message) EF .arrow

  val arr maintain my node : ( (internal message × Unix .inet addr ) , Unix .inet addr ) EF .arrow
  val arr maintain my view : ( (internal message × View .t) , View .t ) EF .arrow


                                                    187
188                                                      CHAPTER 28. GENERIC GOSSIP PROTOCOL

  type state = {
    my node : Unix .inet addr ;
    my view : View .t ;
    command : internal message;
  }
  val   arr   send view : (state, net output) EF .arrow
  val   arr   do exchange view : (state, net output) EF .arrow
  val   arr   contact bootstrap : (state, net output) EF .arrow
  val   arr   init request view exchange : (state, timer output) EF .arrow
  val   arr   init open port : (state, net output) EF .arrow
  val arr to network : ( net output , output ) EF .arrow
  val arr to timer : ( timer output, output ) EF .arrow
end


28.2          Module Gossip
module EF = Event function
open EF
module Gossip
   ( Specification : Gossip signatures.GOSSIP SPECIFICATION )
   =
struct
  module Spec = Specification
  module View = Spec.View
  let empty peer address () = Unix .inet addr of string "127.0.0.1"
  let arr interpret =
     Spec.arr filter >>>
       ( ( Spec.arr interpret network |||
                 Spec.arr interpret user ) |||
              Spec.arr interpret timer )
  let arr duplicate () = pure ˜name :"duplicate" ( fun x → ( x , x ) )
  let my node pprinter ppf node =
     Format.fprintf ppf "%s" (Unix .string of inet addr node)
  let arr maintain my node =
     dloop
       ˜state id :"my node"
       ˜state printer : my node pprinter
       (empty peer address ())
       ( (Spec.arr maintain my node) >>> (arr duplicate ()) )
  let arr maintain my view () =
     dloop
       ˜state id :"my view"
       ˜state printer : View .print view
       View .empty
       ( Spec.arr maintain my view >>> (arr duplicate ()) )
28.2. MODULE GOSSIP                                                                    189

  let arr maintainance =
     ( pure ˜name :"dup3" (fun x → ( ( x , x ) , x )) )
     >>>
        ((arr maintain my node
             $$$ ( arr maintain my view ()))
           $$$ (pure (fun x → x )))
  let to state ( (my node , my view ) , query ) =
     {
        Spec.my node = my node ;
        Spec.my view = my view ;
        Spec.command = query
     }
  let arr to state = pure to state
  let arr network actions = ( Spec.arr send view
                               &&— Spec.arr do exchange view
                               &&— Spec.arr contact bootstrap
                               &&— Spec.arr init open port ) >>> Spec.arr to network
  let arr timer actions = Spec.arr init request view exchange >>> Spec.arr to timer
  let arr actions = arr network actions &&| arr timer actions
  let gossip eventfunction =
     arr interpret
     >>> arr maintainance
     >>> arr to state
     >>> arr actions
end
190   CHAPTER 28. GENERIC GOSSIP PROTOCOL
Chapter 29

The Cyclon Protocol

29.1     Module Cyclon view
module CyclonView =
struct
 type t =
      {
        max size : int ;
        current size : int ;
        my addr : Unix .inet addr ;
        peers : ( float × Unix .inet addr ) list
      }
 let is empty view = view .peers = [ ]
 let rec first k k list =
    match k with
       | 0 → []
       |   →
           match list with
              | [] → []
              | h :: t →
                   h :: ( first k (k − 1) t)
 let merge view1 view2 =
    let merge =
       List.merge
          (fun p1 p2 → compare (fst p1 ) (fst p2 ))
          view1 .peers
          (List.filter (fun ( , peer ) → peer = view1 .my addr ) view2 .peers)
    in
    let peers = first k view1 .max size merge in
    let sum size = view1 .current size + view2 .current size in
    let max size = view1 .max size in
    let current size =
       if sum size < max size then
          sum size

                                                   191
192                                                            CHAPTER 29. THE CYCLON PROTOCOL

           else
              max size
      in
           { view1 with
                current size = current size ;
                peers = peers }
  let insert time peer view =
     let peers = List.filter (fun ( , opeer ) → opeer = peer ∧ opeer = view .my addr ) view .peers in
     let current size = List.length peers in
        if current size ≥ view .max size then
           let peers = first k (current size − 1) peers in
           let peers = ( time , peer ) :: peers in
              { view with
                   peers = peers ;
                   current size = current size }
        else
           let peers = ( time , peer ) :: peers in
              { view with
                   current size = current size + 1 ;
                   peers = peers }
  let pick random rand view =
     let size of view = float of int (List.length view .peers) in
     let random int = int of float (rand size of view ) in
        List.nth view .peers random int
  let string of view view =
     match view .peers with
        | [ ] → "[ Empty View ]"
        |     →
              let str view = List.fold left (fun c p → (Unix .string of inet addr (snd p)) ˆ " ; " ˆ c ) "" view .peers in
                 "[ " ˆ str view ˆ "]"
  let update my addr my addr view = { view with my addr = my addr }
  let empty max size =
     { max size = max size ;
       current size = 0 ;
       my addr = Unix .inet addr of string "127.0.0.1" ;
       peers = [ ] }
end


29.2          Module Cyclon network messages
open Cyclon view
type message =
  | My view is of ( Unix .inet addr × CyclonView .t )
  | Acknowledge view with of ( Unix .inet addr × CyclonView .t )
  | Join of Unix .inet addr
  | Hello of Unix .inet addr
29.3. MODULE CYCLON TIMERS                                                     193

let print message ppf message =
   match message with
     | My view is ( addr , view ) →
          Format.fprintf ppf "My view is ( %s , %s )"
            (Unix .string of inet addr addr )
            (CyclonView .string of view view )
     | Acknowledge view with ( addr , view ) →
          Format.fprintf ppf "Acknowledge view with ( %s , %s )"
            (Unix .string of inet addr addr )
            (CyclonView .string of view view )
     | Join ( addr ) →
          Format.fprintf ppf "Join ( %s )"
            (Unix .string of inet addr addr )
     | Hello ( addr ) →
          Format.fprintf ppf "Hello ( %s )"
            (Unix .string of inet addr addr )
let signature of message message = Marshal .to string message [ ]
let to string message message = Marshal .to string message [ ]
let from string message string = ( Marshal .from string string 0 : message )


29.3      Module Cyclon timers
module Timers =
struct



29.3.1    Type definition
  timers throwable in the system
  type timers =
    | Exchange view



29.3.2    Pretty-printer
  let print timers ppf t =
     match t with
       | Exchange view → Format.fprintf ppf "Exchange view"
  let signature of command command = "exchange view"
end


29.4      Module Cyclon user
module User =
struct
194                                                           CHAPTER 29. THE CYCLON PROTOCOL

29.4.1     Type definitions
  user feedback are events sent to the arrow
  type user feedback =
    | Init of ( Unix .inet addr × Unix .inet addr )
    | Init alone of Unix .inet addr
  There is not user action, the arrow do not interact with the user
  type user action = None action




29.4.2     Pretty-printers
  print user feedback formater user feedback does what is name suggest
  let print user feedback ppf feedback =
     match feedback with
       | Init ( my address, bootstrap address ) →
            Format.fprintf ppf
              "@[Init(@ me: %s@ ,@ boot: %s@ )@]"
              (Unix .string of inet addr my address)
              (Unix .string of inet addr bootstrap address)
       | Init alone my address →
            Format.fprintf ppf
              "@[Init alone(@ me: %s@ )@]"
              (Unix .string of inet addr my address)
  print user action formater user action does almost nothing
  let print user action ppf action = Format.fprintf ppf "%s" "None action"




29.4.3     Simulator Multiplexer interfaces
  user interface timer address user action does nothing here
  let user interface   = ()
end


29.5      Module Cyclon lib
open Event function
open Cyclon view
open Cyclon network messages
open Cyclon timers.Timers
29.5. MODULE CYCLON LIB                                                   195

29.5.1    General parameters

let exchange view period = 5.
let max view size = 1
let port = 1000
let empty peer address () = Unix .inet addr of string "127.0.0.1"
let make address peer = Unix .ADDR INET ( peer , port )
module CyclonGossip =
struct



29.5.2    Types declarations

  module View =
  struct
     type t = CyclonView .t
     let empty = CyclonView .empty max view size
     let print view ppf view =
        Format.fprintf ppf "%s" (CyclonView .string of view view )
  end
  type internal message =
    | No event
    | Receive view of ( Unix .inet addr × CyclonView .t )
    | Acknowledge view of ( Unix .inet addr × CyclonView .t )
    | Joining peer of Unix .inet addr
    | Bootstrap init of ( Unix .inet addr × Unix .inet addr )
    | Single init of Unix .inet addr
    | Request view exchange
    | Hello from of Unix .inet addr
  type cyclon timer = { cyclon delay : float ; cyclon command : timers }
  type net input =
    | Cyclon UDP in of Unix .sockaddr × message
    | Cyclon any net event
  type user input =
    | Cyclon init of Unix .inet addr × Unix .inet addr
    | Cyclon init alone of Unix .inet addr
    | Cyclon any user event
  type timer input =
    | Cyclon timeout of cyclon timer
    | Cyclon any timer event
  type input =
    | Cyclon net in of net input
    | Cyclon timer in of timer input
    | Cyclon user in of user input
196                                                      CHAPTER 29. THE CYCLON PROTOCOL

 type net output =
   | Cyclon network do nothing
   | Cyclon listen on of int
   | Cyclon send of Unix .sockaddr × message
 type timer output =
   | Cyclon launch timer of cyclon timer
   | Cyclon timer do nothing
 type user output = No user output
 type output =
   | Cyclon net out of net output
   | Cyclon timer out of timer output
   | Cyclon user out of user output



29.5.3    Interpret inputs

  let filter query =
     match query with
       | Cyclon net in x → Left (Left ( x ) )
       | Cyclon user in x → Left (Right ( x ))
       | Cyclon timer in x → Right x
  let arr filter = pure filter
 let interpret network query =
    match query with
       | Cyclon UDP in ( addr , payload ) →
              begin
                match payload with
                   | My view is ( peer , view ) → Receive view ( peer , view )
                   | Acknowledge view with ( peer , view ) → Acknowledge view ( peer , view )
                   | Join ( peer ) → Joining peer ( peer )
                   | Hello ( peer ) → Hello from ( peer )
              end
       | Cyclon any net event → No event
 let arr interpret network = pure interpret network
  let interpret user query =
     match query with
        | Cyclon init ( my node , bootstrap node ) → Bootstrap init ( my node , bootstrap node )
        | Cyclon init alone my node → Single init ( my node )
        | Cyclon any user event → No event
  let arr interpret user = pure interpret user
  let interpret timer query =
     match query with
        | Cyclon timeout { cyclon command = Exchange view } → Request view exchange
        | Cyclon any timer event → No event
  let arr interpret timer = pure interpret timer
29.5. MODULE CYCLON LIB                                              197

29.5.4   Maintainance
 Maintain the node
 let maintain my node ( query , my node ) =
    match query with
      | Single init (my node)
      | Bootstrap init ( my node , ) →
          my node
      |   → my node
 let arr maintain my node = pure maintain my node
 Maintain the view:
 let maintain my view ( time , ( query , my view ) ) =
    match query with
      | Acknowledge view ( peer , peer view )
      | Receive view ( peer , peer view ) →
          let peer view = CyclonView .merge my view peer view in
             CyclonView .insert time peer peer view
                      | Hello from peer
      | Joining peer peer →
                    my view
      | Single init my node →
          CyclonView .update my addr my node my view
      | Bootstrap init ( my node , bootnode ) →
          let view = CyclonView .update my addr my node my view in
                      view
     |    → my view
 let print view ( printer , view ) =
    printer ((CyclonView .string of view view ) ˆ "\n");
    flush stdout;
    view
 let arr maintain my view =
    arr timed maintain my view

 type state =
      {
        my node : Unix .inet addr ;
        my view : CyclonView .t ;
        command : internal message
      }



29.5.5   React

 let send view ( query , old view ) =
    match query.command with
      | Joining peer peer →
198                                                        CHAPTER 29. THE CYCLON PROTOCOL

            let peer addr = make address peer in
                      let payload = My view is (query.my node , old view ) in
               ( Cyclon send ( peer addr , payload ) , query.my view )
       | Receive view ( peer , ) when ¬ ( CyclonView .is empty old view ) →
            let peer addr = make address peer in
            let payload = Acknowledge view with (query.my node, old view ) in
               ( Cyclon send ( peer addr , payload ) , query.my view )
       | Bootstrap init ( , bootstrap ) →
                      ( Cyclon network do nothing , CyclonView .insert 0. bootstrap old view )
                      | Acknowledge view    →
            ( Cyclon network do nothing , query.my view )
       |    →
            ( Cyclon network do nothing , old view )
  let arr send view = dloop View .empty (pure send view )
  let do exchange view (rand , query) =
     match query.command with
       | Request view exchange when ¬ (CyclonView .is empty query.my view ) →
           let ( , peer ) = CyclonView .pick random rand query.my view in
           let peer addr = make address peer in
           let payload = My view is (query.my node , query.my view ) in
              Cyclon send ( peer addr , payload )
       |   → Cyclon network do nothing
  let arr do exchange view = arr rand do exchange view
  let contact bootstrap query =
     match query.command with
       | Bootstrap init ( , bootstrap peer ) →
            let peer addr = make address bootstrap peer in
            let payload = Join query.my node in
               Cyclon send ( peer addr , payload )
       |    → Cyclon network do nothing
  let arr contact bootstrap = pure contact bootstrap
 Init:
 let init request view exchange query =
    match query.command with
       | Single init ( )
       | Bootstrap init ( ) →
           Cyclon launch timer { cyclon delay = exchange view period ;
                                  cyclon command = Exchange view }
       |   → Cyclon timer do nothing
 let arr init request view exchange = pure init request view exchange
 let init open port query =
    match query.command with
       | Single init ( )
       | Bootstrap init ( ) →
           Cyclon listen on port
       |   → Cyclon network do nothing
 let arr init open port = pure init open port
29.6. MODULE CYCLON                                                                                  199

  let arr to network = pure (fun x → Cyclon net out x )
  let arr to timer = pure (fun x → Cyclon timer out x )
end
module CyclonGossipC = ( CyclonGossip : Gossip signatures.GOSSIP SPECIFICATION )
module Cyclon = Gossip.Gossip ( CyclonGossip )


29.6      Module Cyclon
module Timer = Simulator timer .Timer ( Cyclon timers.Timers )
module Launcher = Debugger launcher .Launcher
  ( Cyclon simulation properties.SimulationProperties )
  ( Cyclon simulated user .SimulatedUser )
  ( Timer )
  ( Cyclon network messages )
open Cyclon simulated user .SimulatedUser
open Event function
open Timer
open Cyclon timers.Timers
open Launcher .Network
open Cyclon lib
open Cyclon lib.Cyclon
open Cyclon lib.CyclonGossip
let pre treatment ( query : Launcher .multiplexer input ) =
   match query with
     | ‘Network in ( UDP in ( x , y ) ) → Cyclon net in ( Cyclon UDP in ( x , y ) )
     | ‘Network in ( ) → Cyclon net in ( Cyclon any net event )
     | ‘User in ( Init ( x , y ) ) → Cyclon user in ( Cyclon init ( x , y ) )
     | ‘User in ( Init alone x ) → Cyclon user in ( Cyclon init alone x )
     | ‘Timer in ( Timeout ( { Timer .command = Exchange view } as x ) ) →
          Cyclon timer in ( Cyclon timeout { cyclon delay = x .delay ; cyclon command = x .Timer .command } )
     | ‘Timer in ( ) → Cyclon timer in ( Cyclon any timer event )
let arr pre treatment = pure pre treatment
let post treatment ( query : CyclonGossip.output ) =
   match query with
     | Cyclon net out Cyclon network do nothing → Launcher .Network out Network do nothing
     | Cyclon net out ( Cyclon listen on port) → Launcher .Network out ( Listen on ( port , UDP ) )
     | Cyclon net out ( Cyclon send ( addr , payload ) ) → Launcher .Network out ( Send ( addr , UDP , payload ) )
     | Cyclon timer out ( Cyclon launch timer { cyclon delay = delay ; cyclon command = command } ) →

         Launcher .Timer out ( Launch timer { delay = delay ; timer type = Periodic ; Timer .command = command } )
     | Cyclon timer out Cyclon timer do nothing → Launcher .Timer out ( Timer do nothing )
     | Cyclon user out   → Launcher .Do nothing
let arr post treatment = pure post treatment
200                                                         CHAPTER 29. THE CYCLON PROTOCOL

let printer multiplexer in (print , input) =
   Format.fprintf Format.str formatter "@[IN : %a@]@." Launcher .string of multiplexer in input;
   print (Format.flush str formatter ());
   flush stdout;
   input
let arr printer multiplexer in () = arr print ˜name :"printer multiplexer in" printer multiplexer in

let printer multiplexer out ( print , output ) =
   match output with
      | Launcher .Do nothing → output
      |   →
          Format.fprintf Format.str formatter "@[OUT : %a@]@." Launcher .string of multiplexer out output;
          print (Format.flush str formatter ());
          flush stdout;
          output
let arr printer multiplexer out () = arr print ˜name :"printer multiplexer in" printer multiplexer out

let =
   Launcher .launcher (
         arr pre treatment >>>
       gossip eventfunction >>>
       arr post treatment
       )



29.7     Module Cyclon simulated user
module SimulatedUser =
struct




29.7.1    Type definitions
  user feedback are events sent to the arrow

  type user feedback =
    | Init of ( Unix .inet addr × Unix .inet addr )
    | Init alone of Unix .inet addr

  There is not user action, the arrow do not interact with the user

  type user action = None action




29.7.2    Pretty-printers
  print user feedback formater user feedback does what is name suggest
29.8. MODULE CYCLON SIMULATION PROPERTIES                                                              201

  let print user feedback ppf feedback =
     match feedback with
       | Init ( my address, bootstrap address ) →
            Format.fprintf ppf
              "@[Init(@ me: %s@ ,@ boot: %s@ )@]"
              (Unix .string of inet addr my address)
              (Unix .string of inet addr bootstrap address)
       | Init alone my address →
            Format.fprintf ppf
              "@[Init alone(@ me: %s@ )@]"
              (Unix .string of inet addr my address)
  print user action formater user action does almost nothing
  let print user action ppf action = Format.fprintf ppf "%s" "None action"



29.7.3    Simulator Multiplexer interfaces
  init my address sets up the node
  let init address =
     let root = Unix .inet addr of string "10.0.0.0"
     in
        if ( address = 0 ) then
           (∗ We are the bootstraping node ∗)
           Init alone root
        else
           Init ( (Int to inet.inet addr of int address) , Int to inet.inet addr of int(Random.int address) )
  user interface timer address user action does nothing here
  let user interface time address user action =
     None
end


29.8     Module Cyclon simulation properties
module SimulationProperties =
struct
   let network size = 4
   let end time = 1000
   let slow = false
   let latency     = 1.
end


29.9     Module Cyclon modelchecking user
module ModelcheckingUser =
struct
202                                                           CHAPTER 29. THE CYCLON PROTOCOL

29.9.1    Type definitions
  user feedback are events sent to the arrow
  type user feedback =
    | Init of ( Unix .inet addr × Unix .inet addr )
    | Init alone of Unix .inet addr
  There is not user action, the arrow do not interact with the user
  type user action = None action



29.9.2    Pretty-printers
  print user feedback formater user feedback does what is name suggest
  let print user feedback ppf feedback =
     match feedback with
       | Init ( my address, bootstrap address ) →
            Format.fprintf ppf
              "@[Init(@ me: %s@ ,@ boot: %s@ )@]"
              (Unix .string of inet addr my address)
              (Unix .string of inet addr bootstrap address)
       | Init alone my address →
            Format.fprintf ppf
              "@[Init alone(@ me: %s@ )@]"
              (Unix .string of inet addr my address)
  print user action formater user action does almost nothing
  let print user action ppf action = Format.fprintf ppf "%s" "None action"



29.9.3    Simulator Multiplexer interfaces
  init my address sets up the node
  let init address =
     let root = Unix .inet addr of string "10.0.0.0"
     in
        if ( address = 0 ) then
           (∗ We are the bootstraping node ∗)
           Init alone root
        else
           Init ( (Int to inet.inet addr of int address) , Int to inet.inet addr of int(Random.int address) )
  user interface timer address user action does nothing here
  let user interface time address user action =
     None
end
29.10. MODULE CYCLON MODELCHECKING PROPERTIES                                                 203

29.10       Module Cyclon modelchecking properties
module ModelcheckingProperties =
struct
   let network size = 4
   let rand x = 0. (∗ I have randomly choosen 0 ∗)
   let printer s = ()
end


29.11       Module Cyclon property
module EF = Event function
open Cyclon view
module Property
   ( NetworkMap : Map.S with type key = int ) =
struct
  module Timer = Modelchecker timer .Timer ( Cyclon timers.Timers )
  module User = Cyclon modelchecking user .ModelcheckingUser
  module Network =
   struct
      include ( Network interface types.NetworkInterfaceTypes ( Cyclon network messages ) )
      let network interface   = failwith "Property: call to network interface"
   end
  module Peer = Modelchecker peer .Make
   ( Cyclon modelchecking user .ModelcheckingUser )
   ( Timer )
   ( Cyclon network messages )
  open   Timer
  open   User
  open   Network
  open   Peer
  type property =
    | Safety
    | Liveness
    | Safety partial
    | Bounded safety of int
  let kind of property = Safety
  let forall peer p network =
     try
        ignore (
          NetworkMap.iter
             ( fun addr peer →
                  if ¬ ( p addr peer ) then
                     raise Not found ;
             )
204                                                         CHAPTER 29. THE CYCLON PROTOCOL

             network );
        true
      with
        | Not found → false
  let exists peer p network =
     ¬ (forall peer (fun key peer → ¬ (p key peer )) network )
  module HashAddressType =
   struct
      type t = Unix .inet addr
      let equal = (=)
      let hash = Hashtbl .hash
   end
  module HashAddress = Hashtbl .Make ( HashAddressType )
 exception Found
 let property network =
    let is strongly connected network =
       let network size = NetworkMap.fold (fun          c → c + 1) network 0 in
       let traversed = HashAddress.create 50 in
       let view event function =
          let repr view = List.assoc "my view" (EF .get states event function) in
          let value view = ( Obj .obj repr view : Cyclon view .CyclonView .t ) in
             List.map snd value view .Cyclon view .CyclonView .peers
       in
       let graph = HashAddress.create 50 in
       let rec traversal ip =
          try
             ignore ( HashAddress.find traversed ip );
          with
             | Not found →
                  HashAddress.add traversed ip true;
                  let dest ips = HashAddress.find graph ip in
                     List.iter
                       traversal
                       dest ips
       in
          NetworkMap.iter
             ( fun peer →
                  let peer ip = peer .address in
                  let peer view = view peer .process in
                     HashAddress.add graph peer ip peer view )
             network ;
          traversal (NetworkMap.find 0 network ).address;
          network size = HashAddress.length traversed
    in
    let view filled peer =
       let event function = peer .process in
       let repr view = List.assoc "my view" (EF .get states event function) in
       let view = ( Obj .obj repr view : Cyclon view .CyclonView .t ) in
29.11. MODULE CYCLON PROPERTY                                                                        205

             view .Cyclon view .CyclonView .max size = view .Cyclon view .CyclonView .current size
      in
           if ( (forall peer view filled network ) ) then
              begin
                 Printf .printf "Views filled\n";
                 is strongly connected network
              end
           else
              true
end
206   CHAPTER 29. THE CYCLON PROTOCOL
Chapter 30

The Vicinity Protocol

30.1      Module Vicinity view
type semantic value = int list
module VicinityView =
struct
  type peer =
       {
         timestamp : float ;
         addr : Unix .inet addr ;
         semantic value : semantic value
       }
  type t =
       {
         max size : int ;
         current size : int ;
         my semantic value : semantic value ;
         my addr : Unix .inet addr ;
         peers : peer list
       }
  let is empty view = view .peers = [ ]
  let update my semantic value my node semantic value view =
     { view with my semantic value = semantic value ; my addr = my node }
  let rec first k k list =
     match k with
        | 0 → []
        |   →
            match list with
               | [] → []
               | h :: t →
                    h :: ( first k (k − 1) t)


                                                207
208                                                       CHAPTER 30. THE VICINITY PROTOCOL

 let semantic matching semantic ref semantic value =
    match semantic ref with
      | [ ] → failwith "semantic matching: semantic reference value empty"
      |     →
            let no common elt = List.length ( List.filter (fun x → List.mem x semantic ref ) semantic value ) in
               (float of int no common elt) /. (float of int (List.length semantic ref ))
  let compare semantic semantic ref semantic1 semantic2 =
     match semantic ref with
       | [ ] → failwith "compare semantic: semantic reference value empty"
       |     →
             let no common elt l = List.length ( List.filter (fun x → List.mem x semantic ref ) l ) in
                compare (no common elt semantic1 ) (no common elt semantic2 )
  let rec unique elts equal list =
     match list with
        | [] → []
        | h :: t →
             if List.exists (equal h) t then
                unique elts equal t
             else
                h :: ( unique elts equal t )
  let rec naive insertion compare elt list =
     match list with
        | [ ] → [ elt ]
        | h :: t when compare h elt < 0 → h :: naive insertion compare elt t
        | h :: t → elt :: h :: t
  let rec insertion ( ( elt v , elt ) as eltv ) list acc =
     match list with
        | [ ] → List.rev ( eltv :: acc )
        | ( ( v , h ) as vh ) :: t when v > elt v → insertion eltv t ( vh :: acc )
        | vh :: t → ( List.rev acc ) @ eltv :: vh :: t
  let rec sort and remove forbidden elt list sorted list =
     match list with
        | [ ] → sorted list
        | ( , h ) :: t when h.addr = forbidden elt → sort and remove forbidden elt t sorted list
        | ( v , h ) :: t →
              let sorted list = insertion ( v , h ) sorted list [ ] in
                 sort and remove forbidden elt t sorted list
  let merge view1 view2 =
     let reference semantic = view1 .my semantic value in
     let tag list of peers =
        List.map
           ( fun peer →
                let sem coeff = semantic matching reference semantic peer .semantic value in
                   ( sem coeff , peer ) )
     in
     let tagged peers1 = tag list of peers view1 .peers in
     let tagged peers2 = tag list of peers view2 .peers in
30.1. MODULE VICINITY VIEW                                                                             209

     let sorted peers2 = sort and remove view1 .my addr tagged peers2 [ ] in
     let rec merge int k peers1 peers2 acc =
        match k with
           | 0 → ( k , acc )
           |   →
               match ( peers1 , peers2 ) with
                 | ( ( v1 , h1 ) :: t1 ) , ( ( v2 , h2 ) ::         ) when v1 > v2 → merge int (k −
1) t1 peers2 ( h1 :: acc )
                 | ( ( v1 , h1 ) ::        ) , ( ( v2 , h2 ) :: t2 ) when v1 < v2 → merge int (k −
1) peers1 t2 ( h2 :: acc )
                 | ( ( , h1 ) :: t1 ) , ( ( , h2 ) ::       ) when h1 .addr = h2 .addr → merge int (k −
1) t1 peers2 ( h1 :: acc )
                 | ( ( , h1 ) :: t1 ) , ( ( , h2 ) :: t2 ) → merge int (k − 1) t1 t2 ( h1 :: acc )
                 | [ ] , [ ] → ( k , acc )
                 | [ ] , ( ( , h ) :: t ) → merge int (k − 1) peers1 t ( h :: acc )
                 | ( ( , h ) :: t ) , [ ] → merge int (k − 1) peers2 t ( h :: acc )

    in
    let ( free slots , merged peers ) = merge int view1 .max size tagged peers1 sorted peers2 [ ] in
       { view1 with
             peers = List.rev merged peers ;
             current size = view1 .max size − free slots }

  let insert time peer semantic value view =
     let peers = List.filter (fun elt → elt.addr = peer ) view .peers in
     let peers =
        naive insertion
          (fun v1 v2 → − ( compare semantic view .my semantic value v1 .semantic value v2 .semantic value ) )
          { timestamp = time ; addr = peer ; semantic value = semantic value }
          peers
     in
     let peers = first k view .max size peers in
        { view with
             peers = peers ;
             current size = List.length peers }

  let index max l =
     let rec index max int pos pos max val max l =
        match l with
           | [ ] → pos max
           | h :: t →
                 if ( h > val max ) then
                    index max int (pos + 1) pos h t
                 else
                    index max int (pos + 1) pos max val max t
     in
        match l with
           | [ ] → failwith "index max: empty list"
           |     →
                 index max int 0 0 0. l
210                                                        CHAPTER 30. THE VICINITY PROTOCOL

  let pick closest view =
     let semantic matchings = List.map (fun p → semantic matching view .my semantic value p.semantic value) view .pee
     let index closest peer = index max semantic matchings in
        List.nth view .peers index closest peer
  let string of semantic value =
     List.fold left
        (fun c p → (string of int p) ˆ ", " ˆ c )
        ""
  let string of view view =
     match view .peers with
        | [ ] → "[ Empty View ]"
        |     →
              let sem = string of semantic value view .my semantic value in
              let str view =
                 List.fold left
                    (fun c p →
                        (Unix .string of inet addr p.addr ) ˆ
                          ":" ˆ (string of float (semantic matching view .my semantic value p.semantic value)) ˆ
                                     " ; " ˆ c ) "" view .peers
                     in
                 "[ " ˆ sem ˆ "| " ˆ str view ˆ "]"
  let empty semantic value max size =
     { max size = max size ;
       current size = 0 ;
       my semantic value = semantic value ;
       my addr = Unix .inet addr of string "127.0.0.1" ;
       peers = [ ] }
end


30.2      Module Vicinity network messages
open Vicinity view
type message =
  | My view is of ( Unix .inet addr × VicinityView .t )
  | Join of Unix .inet addr × semantic value
  | Hello
let print message ppf message =
   match message with
     | My view is ( addr , view ) →
          Format.fprintf ppf "My view is ( %s , %s )"
            (Unix .string of inet addr addr )
            (VicinityView .string of view view )
     | Join ( addr , semantic value ) →
          Format.fprintf ppf "Join ( %s , %s )"
            (Unix .string of inet addr addr )
            (VicinityView .string of semantic value semantic value)
     | Hello → Format.fprintf ppf "Hello"
30.3. MODULE VICINITY TIMERS                                                          211

let signature of message message = Marshal .to string message [ ]
let to string message message = Marshal .to string message [ ]
let from string message string = ( Marshal .from string string 0 : message )


30.3      Module Vicinity timers
module Timers =
struct




30.3.1    Type definition
  timers throwable in the system
  type timers =
    | Exchange view




30.3.2    Pretty-printer

  let print timers ppf t =
     match t with
       | Exchange view → Format.fprintf ppf "Exchange view"
  let signature of command command = "exchange view"
end


30.4      Module Vicinity user
module User =
struct




30.4.1    Type definitions
  user feedback are events sent to the arrow
  type user feedback =
    | Init of ( Unix .inet addr × Vicinity view .semantic value × Unix .inet addr )
    | Init alone of ( Unix .inet addr × Vicinity view .semantic value )
  There is not user action, the arrow do not interact with the user
  type user action = None action
212                                                       CHAPTER 30. THE VICINITY PROTOCOL

30.4.2     Pretty-printers
  print user feedback formater user feedback does what is name suggest
  let print user feedback ppf feedback =
     match feedback with
       | Init ( my address, , bootstrap address ) →
            Format.fprintf ppf
              "@[Init(@ me: %s@ ,@ boot: %s@ )@]"
              (Unix .string of inet addr my address)
              (Unix .string of inet addr bootstrap address)
       | Init alone ( my address , ) →
            Format.fprintf ppf
              "@[Init alone(@ me: %s@ )@]"
              (Unix .string of inet addr my address)
  print user action formater user action does almost nothing
  let print user action ppf action = Format.fprintf ppf "%s" "None action"



30.4.3     Simulator Multiplexer interfaces
  user interface timer address user action does nothing here
  let user interface   = ()
end


30.5      Module Vicinity lib
open Event function
open Vicinity view
open Vicinity timers.Timers
open Vicinity network messages



30.5.1     General parameters

let exchange view period = 5.
let max view size = 16
let port = 1001
let empty peer address () = Unix .inet addr of string "127.0.0.1"
let make address peer = Unix .ADDR INET ( peer , port )
module VicinityGossip =
struct
30.5. MODULE VICINITY LIB                                                       213

30.5.2   Types declarations

 module View =
 struct
    type t = VicinityView .t
    let empty = VicinityView .empty [ ] max view size
    let print view ppf view =
       Format.fprintf ppf "%s" (VicinityView .string of view view )
 end

 type internal message =
   | No event
   | Receive view of ( Unix .inet addr × VicinityView .t )
   | Joining peer of Unix .inet addr × semantic value
   | Bootstrap init of ( Unix .inet addr × semantic value × Unix .inet addr )
   | Single init of Unix .inet addr × semantic value
   | Request view exchange
   | Hello from of Unix .inet addr

 type semantic timer = { vicinity delay : float ; vicinity command : timers }

 type net input =
   | Vicinity UDP in of Unix .sockaddr × message
   | Vicinity any net event
 type user input =
   | Vicinity init of Unix .inet addr × semantic value × Unix .inet addr
   | Vicinity init alone of Unix .inet addr × semantic value
   | Vicinity any user event
 type timer input =
   | Vicinity timeout of semantic timer
   | Vicinity any timer event
 type input =
   | Vicinity net in of net input
   | Vicinity timer in of timer input
   | Vicinity user in of user input

 type net output =
   | Vicinity network do nothing
   | Vicinity listen on of int
   | Vicinity send of Unix .sockaddr × message
 type timer output =
   | Vicinity launch timer of semantic timer
   | Vicinity timer do nothing
 type user output = No user output
 type output =
   | Vicinity net out of net output
   | Vicinity timer out of timer output
   | Vicinity user out of user output
214                                                      CHAPTER 30. THE VICINITY PROTOCOL

30.5.3    Interpret inputs

  let filter query =
     match query with
       | Vicinity net in x → Left (Left ( x ) )
       | Vicinity user in x → Left (Right ( x ))
       | Vicinity timer in x → Right x
  let arr filter = pure ˜name :"filter" filter

  let interpret network query =
     match query with
        | Vicinity UDP in ( addr , payload ) →
            begin
               match payload with
                 | My view is ( peer , view ) → Receive view ( peer , view )
                 | Join ( peer , semantic value ) → Joining peer ( peer , semantic value )
                 | Hello → Hello from ( Net general .inet addr of sockaddr addr )
            end
        | Vicinity any net event → No event
  let arr interpret network = pure ˜name :"interpret network" interpret network

 let interpret user query =
    match query with
       | Vicinity init ( my node , my semantic value , bootstrap node ) → Bootstrap init ( my node , my semantic value
       | Vicinity init alone ( my node , my semantic value ) → Single init ( my node , my semantic value )
       | Vicinity any user event → No event
 let arr interpret user = pure ˜name :"interpret user" interpret user

  let interpret timer query =
     match query with
        | Vicinity timeout { vicinity command = Exchange view } → Request view exchange
        | Vicinity any timer event → No event
  let arr interpret timer = pure ˜name :"interpret timer" interpret timer




30.5.4    Maintainance
  Maintain the node:

  let maintain my node ( query , my node ) =
     match query with
       | Single init (my node , )
       | Bootstrap init ( my node , , ) →
           my node
       |   → my node
  let arr maintain my node = pure ˜name :"maintain my node" maintain my node

 Maintain the view:
30.5. MODULE VICINITY LIB                                                                            215

 let maintain my view ( time , ( query , my view ) ) =
    match query with
      | Receive view ( peer , peer view ) →
          let merged view = VicinityView .merge my view peer view in
             VicinityView .insert time peer peer view .VicinityView .my semantic value merged view
      | Joining peer ( peer , semantic value ) →
          VicinityView .insert time peer semantic value my view
      | Single init ( my node , semantic value )
      | Bootstrap init ( my node , semantic value , ) →
          VicinityView .update my semantic value my node semantic value my view
      |   → my view
 let print view ( printer , view ) =
    printer ((VicinityView .string of view view ) ˆ "\n");
    flush stdout;
    view
 let arr maintain my view =
    arr timed ˜name :"maintain my view" maintain my view

 type state =
      {
        my node : Unix .inet addr ;
        my view : VicinityView .t ;
        command : internal message
      }



30.5.5   React
 let send view query =
    match query.command with
      | Receive view ( peer , )
      | Hello from ( peer )
      | Joining peer ( peer , ) →
           let peer addr = make address peer in
           let payload = My view is (query.my node , query.my view ) in
              Vicinity send ( peer addr , payload )
      |    → Vicinity network do nothing
 let arr send view = pure ˜name :"send view" send view
 let do exchange view query =
    match query.command with
      | Request view exchange when ¬ (VicinityView .is empty query.my view ) →
          let { VicinityView .addr = peer } = VicinityView .pick closest query.my view in
          let peer addr = make address peer in
          let payload = My view is (query.my node , query.my view ) in
             Vicinity send ( peer addr , payload )
      |   → Vicinity network do nothing
 let arr do exchange view = pure ˜name :"do exchange view" do exchange view
216                                                     CHAPTER 30. THE VICINITY PROTOCOL

  let contact bootstrap query =
     match query.command with
       | Bootstrap init ( , , bootstrap peer ) →
            let peer addr = make address bootstrap peer in
            let payload = Join ( query.my node , query.my view .VicinityView .my semantic value ) in
               Vicinity send ( peer addr , payload )
       |    → Vicinity network do nothing
  let arr contact bootstrap = pure ˜name :"contact bootstrap" contact bootstrap
  Init:
  let init request view exchange query =
     match query.command with
        | Single init ( )
        | Bootstrap init ( ) →
            Vicinity launch timer { vicinity delay = exchange view period ;
                                      vicinity command = Exchange view }
        |   → Vicinity timer do nothing
  let arr init request view exchange =
     pure ˜name :"init request view exchange" init request view exchange
  let init open port query =
     match query.command with
        | Single init ( )
        | Bootstrap init ( ) →
            Vicinity listen on port
        |   → Vicinity network do nothing
  let arr init open port = pure ˜name :"init open port" init open port
  let arr to network = pure ˜name :"to network" (fun x → Vicinity net out x )
  let arr to timer = pure ˜name :"to timer" (fun x → Vicinity timer out x )
end
module VicinityGossipC = ( VicinityGossip : Gossip signatures.GOSSIP SPECIFICATION )
module Vicinity = Gossip.Gossip ( VicinityGossip )
open VicinityGossip


30.6      Module Vicinity
module Timer = Simulator timer .Timer ( Vicinity timers.Timers )
module Launcher = Simulator launcher .Launcher
  ( Vicinity simulation properties.SimulationProperties )
  ( Vicinity simulated user .SimulatedUser )
  ( Timer )
  ( Vicinity network messages )
open Vicinity simulated user .SimulatedUser
open Event function
let =
   set profiling true
30.6. MODULE VICINITY                                                                                 217

open Timer
open Vicinity timers.Timers

open Launcher .Network

open Vicinity network messages

open Vicinity lib
open Vicinity lib.Vicinity
open Vicinity lib.VicinityGossip

let pre treatment ( query : Launcher .multiplexer input ) =
   match query with
     | ‘Network in ( UDP in ( x , y ) ) → Vicinity net in ( Vicinity UDP in ( x , y ) )
     | ‘Network in ( ) → Vicinity net in ( Vicinity any net event )
     | ‘User in ( Init ( x , y , z ) ) → Vicinity user in ( Vicinity init ( x , y , z ) )
     | ‘User in ( Init alone ( x , y ) ) → Vicinity user in ( Vicinity init alone ( x , y ) )
     | ‘Timer in ( Timeout ( { Timer .command = Exchange view } as x ) ) →
          Vicinity timer in ( Vicinity timeout { vicinity delay = x .delay ; vicinity command = x .Timer .command } )
     | ‘Timer in ( ) → Vicinity timer in ( Vicinity any timer event )
let arr pre treatment = pure ˜name :"pre treatment" pre treatment

let post treatment ( query : VicinityGossip.output ) =
   match query with
     | Vicinity net out Vicinity network do nothing → Launcher .Network out Network do nothing
     | Vicinity net out ( Vicinity listen on port) → Launcher .Network out ( Listen on ( port , UDP ) )
     | Vicinity net out ( Vicinity send ( addr , payload ) ) → Launcher .Network out ( Send ( addr , UDP , payload ) )
     | Vicinity timer out ( Vicinity launch timer { vicinity delay = delay ; vicinity command = command } ) →

         Launcher .Timer out ( Launch timer { delay = delay ; timer type = Periodic ; Timer .command = command } )
     | Vicinity timer out Vicinity timer do nothing → Launcher .Timer out ( Timer do nothing )
     | Vicinity user out   → Launcher .Do nothing
let arr post treatment = pure ˜name :"post treatment" post treatment

let printer multiplexer in (print , input) =
   Format.fprintf Format.str formatter "@[IN : %a@]@." Launcher .string of multiplexer in input;
   print (Format.flush str formatter ());
   flush stdout;
   input
let arr printer multiplexer in () = arr print ˜name :"printer multiplexer in" printer multiplexer in

let printer multiplexer out ( print , output ) =
   match output with
      | Launcher .Do nothing → output
      |   →
          Format.fprintf Format.str formatter "@[OUT : %a@]@." Launcher .string of multiplexer out output;
          print (Format.flush str formatter ());
          flush stdout;
          output
let arr printer multiplexer out () = arr print ˜name :"printer multiplexer in" printer multiplexer out
218                                                        CHAPTER 30. THE VICINITY PROTOCOL

let =
   Launcher .launcher ( arr pre treatment >>>
       Vicinity lib.Vicinity.gossip eventfunction >>>
       arr post treatment
       )



30.7     Module Vicinity simulated user
module SimulatedUser =
struct




30.7.1    Type definitions
  user feedback are events sent to the arrow

  type user feedback =
    | Init of ( Unix .inet addr × Vicinity view .semantic value × Unix .inet addr )
    | Init alone of ( Unix .inet addr × Vicinity view .semantic value )

  There is not user action, the arrow do not interact with the user

  type user action = None action




30.7.2    Pretty-printers
  print user feedback formater user feedback does what is name suggest

  let print user feedback ppf feedback =
     match feedback with
       | Init ( my address, , bootstrap address ) →
            Format.fprintf ppf
              "@[Init(@ me: %s@ ,@ boot: %s@ )@]"
              (Unix .string of inet addr my address)
              (Unix .string of inet addr bootstrap address)
       | Init alone ( my address , ) →
            Format.fprintf ppf
              "@[Init alone(@ me: %s@ )@]"
              (Unix .string of inet addr my address)

  print user action formater user action does almost nothing

  let print user action ppf action = Format.fprintf ppf "%s" "None action"
30.8. MODULE VICINITY SIMULATION PROPERTIES                                                          219

30.7.3    Simulator Multiplexer interfaces

  let rec make random semantic value min max size =
     match size with
        | 0 → []
        |   →
            let value = ( Random.int (max − min) ) + min in
               value :: ( make random semantic value min max (size − 1))
  init my address sets up the node
  let init address =
     let root = Unix .inet addr of string "10.0.0.0" in
     let random semantic value = make random semantic value 0 10 5
     in
        if ( address = 0 ) then
           (∗ We are the bootstraping node ∗)
           Init alone ( root , random semantic value )
        else
           Init ( (Int to inet.inet addr of int address) , random semantic value , (Int to inet.inet addr of int (Random.i
  user interface timer address user action does nothing here
  let user interface time address user action =
     None
end


30.8     Module Vicinity simulation properties
module SimulationProperties =
struct
   let network size = 10
   let end time = 100
   let slow = false
   let latency     = 1.
end
220   CHAPTER 30. THE VICINITY PROTOCOL
Chapter 31

The Cyclonity Protocol

31.1     Module Cyclonity network messages
type message =
  | For cyclon of Cyclon network messages.message
  | For vicinity of Vicinity network messages.message
let print message ppf message =
   match message with
       | For cyclon message →
          Format.fprintf ppf "For cyclon ( %a )"
            Cyclon network messages.print message message
     | For vicinity message →
          Format.fprintf ppf "For vicinity ( %a )"
            Vicinity network messages.print message message
let signature of message message = Marshal .to string message [ ]
let to string message message = Marshal .to string message [ ]
let from string message message = ( Marshal .from string message 0 : message )


31.2     Module Cyclonity timers
module Timers =
struct



31.2.1    Type definition
  timers throwable in the system
  type timers =
    | Cyclon exchange view
    | Vicinity exchange view



                                                 221
222                                                    CHAPTER 31. THE CYCLONITY PROTOCOL

31.2.2    Pretty-printer
  let print timers ppf t =
     match t with
       | Cyclon exchange view → Format.fprintf ppf "Cyclon exchange view"
       | Vicinity exchange view → Format.fprintf ppf "Vicinity exchange view"
  let signature of command t =
     match t with
        | Cyclon exchange view → "cyclon exchange view"
        | Vicinity exchange view → "vicinity exchange view"
end


31.3     Module Cyclonity user
module User =
struct



31.3.1    Type definitions
  user feedback are events sent to the arrow
  type user feedback =
    | Init of ( Unix .inet addr × Vicinity view .semantic value × Unix .inet addr )
    | Init alone of Unix .inet addr × Vicinity view .semantic value
  There is not user action, the arrow do not interact with the user
  type user action = None action



31.3.2    Pretty-printers
  print user feedback formater user feedback does what is name suggest
  let print user feedback ppf feedback =
     match feedback with
       | Init ( my address, , bootstrap address ) →
            Format.fprintf ppf
              "@[Init(@ me: %s@ ,@ boot: %s@ )@]"
              (Unix .string of inet addr my address)
              (Unix .string of inet addr bootstrap address)
       | Init alone ( my address , ) →
            Format.fprintf ppf
              "@[Init alone(@ me: %s@ )@]"
              (Unix .string of inet addr my address)
  print user action formater user action does almost nothing
  let print user action ppf action = Format.fprintf ppf "%s" "None action"
31.4. MODULE CYCLONITY                                                                                         223

31.3.3     Simulator Multiplexer interfaces
  user interface timer address user action does nothing here
  let user interface    = ()
end


31.4       Module Cyclonity
module Timer = Simulator timer .Timer ( Cyclonity timers.Timers )
module Launcher = Simulator launcher .Launcher
  ( Cyclonity simulation properties.SimulationProperties )
  ( Cyclonity simulated user .SimulatedUser )
  ( Timer )
  ( Cyclonity network messages )
open Cyclonity simulated user .SimulatedUser
open Timer
open Cyclonity timers.Timers
open Launcher .Network
open Cyclonity network messages
open Event function
Load the event functions:
let cyclon = Cyclon lib.Cyclon.gossip eventfunction
let vicinity = Vicinity lib.Vicinity.gossip eventfunction
Dispatch events:
open Cyclon lib.CyclonGossip
open Vicinity lib.VicinityGossip
type global event =
  | Cyclonity do nothing
  | Cyclonity ask for semantic view of Unix .inet addr
let pre treatment ( query : Launcher .multiplexer input ) =
   match query with
     | ‘Network in ( UDP in ( peer , data ) ) →
          begin match data with
            | For cyclon data →
                 [ Left ( Left ( Cyclon net in ( Cyclon UDP in ( peer , data ) ) ) ) ;
                    Right ( Cyclonity ask for semantic view (Net general .inet addr of sockaddr peer ) ) ]
            | For vicinity data → [ Left ( Right ( Vicinity net in ( Vicinity UDP in ( peer , data ) ) ) ) ]
          end
     | ‘Network in ( ) → [ Right Cyclonity do nothing ]
     | ‘User in ( Init ( x , y , z ) ) → [ Left ( Right ( Vicinity user in ( Vicinity init ( x , y , z ) ) ) ) ;
                                                    Left ( Left ( Cyclon user in ( Cyclon init ( x , z ) ) ) ) ]
     | ‘User in ( Init alone ( x , y ) ) → [ Left ( Right ( Vicinity user in ( Vicinity init alone ( x , y ) ) ) ) ;
                                                       Left ( Left ( Cyclon user in ( Cyclon init alone x ) ) ) ]
     | ‘Timer in ( Timeout ( { Timer .command = Cyclon exchange view } as x ) ) →
224                                                        CHAPTER 31. THE CYCLONITY PROTOCOL

          [ Left   ( Left ( Cyclon timer in ( Cyclon timeout { cyclon delay = x .delay ; cyclon command = Cyclon timers.Ti
      | ‘Timer     in ( Timeout ( { Timer .command = Vicinity exchange view } as x ) ) →
          [ Left   ( Right ( Vicinity timer in ( Vicinity timeout { vicinity delay = x .delay ; vicinity command = Vicinity tim
      | ‘Timer     in ( ) → [ Right Cyclonity do nothing ]
let arr pre treatment = mconcat ( pure pre treatment )
let cyclon post treatment ( query : Cyclon lib.CyclonGossip.output ) =
   match query with
     | Cyclon net out Cyclon network do nothing → Launcher .Network out Network do nothing
     | Cyclon net out ( Cyclon listen on port) → Launcher .Network out ( Listen on ( port , UDP ) )
     | Cyclon net out ( Cyclon send ( addr , payload ) ) →
          let payload = For cyclon payload in
             Launcher .Network out ( Send ( addr , UDP , payload ) )
     | Cyclon timer out ( Cyclon launch timer { cyclon delay = delay ; cyclon command = Cyclon timers.Timers.Exch

         Launcher .Timer out ( Launch timer { delay = delay ; timer type = Periodic ; Timer .command = Cyclon excha
     | Cyclon timer out Cyclon timer do nothing → Launcher .Timer out ( Timer do nothing )
     | Cyclon user out    → Launcher .Do nothing
let arr cyclon post treatment = pure cyclon post treatment
let vicinity post treatment ( query : Vicinity lib.VicinityGossip.output ) =
   match query with
      | Vicinity net out Vicinity network do nothing → Launcher .Network out Network do nothing
      | Vicinity net out ( Vicinity listen on port) → Launcher .Network out ( Listen on ( port , UDP ) )
      | Vicinity net out ( Vicinity send ( addr , payload ) ) →
           let payload = For vicinity payload in
              Launcher .Network out ( Send ( addr , UDP , payload ) )
      | Vicinity timer out ( Vicinity launch timer { vicinity delay = delay ; vicinity command = command } ) →

          Launcher .Timer out ( Launch timer { delay = delay ; timer type = Periodic ; Timer .command = Vicinity exc
     | Vicinity timer out Vicinity timer do nothing → Launcher .Timer out ( Timer do nothing )
     | Vicinity user out    → Launcher .Do nothing
let arr vicinity post treatment = pure vicinity post treatment
let cyclonity post treatment query =
   match query with
     | Cyclonity do nothing → Launcher .Do nothing
     | Cyclonity ask for semantic view peer →
          let peer addr = Vicinity lib.make address peer in
          let payload = Vicinity network messages.Hello in
          let payload = For vicinity payload in
             Launcher .Network out ( Send ( peer addr , UDP , payload ) )
let arr cyclonity post treatment = pure cyclonity post treatment
Probing pretty-printers:
let printer multiplexer in (print , input) =
   Format.fprintf Format.str formatter "@[IN : %a@]@." Launcher .string of multiplexer in input;
   print (Format.flush str formatter ());
   flush stdout;
   input
let arr printer multiplexer in () = arr print ˜name :"printer multiplexer in" printer multiplexer in
31.5. MODULE CYCLONITY SIMULATED USER                                                              225

let printer multiplexer out ( print , output ) =
   match output with
      | Launcher .Do nothing → output
      |   →
          Format.fprintf Format.str formatter "@[OUT : %a@]@." Launcher .string of multiplexer out output;
          print (Format.flush str formatter ());
          flush stdout;
          output
let arr printer multiplexer out () = arr print ˜name :"printer multiplexer in" printer multiplexer out
let =
   Launcher .launcher
     (
         arr pre treatment >>>
         ( ( ( cyclon >>> arr cyclon post treatment )
               ——— ( vicinity >>> arr vicinity post treatment )
            ) ||| arr cyclonity post treatment )
     )


31.5     Module Cyclonity simulated user
module SimulatedUser =
struct



31.5.1    Type definitions
  user feedback are events sent to the arrow
  type user feedback =
    | Init of ( Unix .inet addr × Vicinity view .semantic value × Unix .inet addr )
    | Init alone of Unix .inet addr × Vicinity view .semantic value
  There is not user action, the arrow do not interact with the user
  type user action = None action



31.5.2    Pretty-printers
  print user feedback formater user feedback does what is name suggest
  let print user feedback ppf feedback =
     match feedback with
       | Init ( my address, , bootstrap address ) →
            Format.fprintf ppf
              "@[Init(@ me: %s@ ,@ boot: %s@ )@]"
              (Unix .string of inet addr my address)
              (Unix .string of inet addr bootstrap address)
       | Init alone ( my address , ) →
            Format.fprintf ppf
226                                                    CHAPTER 31. THE CYCLONITY PROTOCOL

             "@[Init alone(@ me: %s@ )@]"
             (Unix .string of inet addr my address)
  print user action formater user action does almost nothing
  let print user action ppf action = Format.fprintf ppf "%s" "None action"



31.5.3    Simulator Multiplexer interfaces

  let rec make random semantic value min max size =
     match size with
        | 0 → []
        |   →
            let value = ( Random.int (max − min) ) + min in
               value :: ( make random semantic value min max (size − 1))
  init my address sets up the node
  let init address =
     let random semantic value = make random semantic value 0 15 8 in
     let root = Unix .inet addr of string "10.0.0.0"
     in
        if ( address = 0 ) then
           (∗ We are the bootstraping node ∗)
           Init alone ( root , random semantic value )
        else
           Init ( (Int to inet.inet addr of int address) , random semantic value , (Int to inet.inet addr of int (Random.i
  user interface timer address user action does nothing here
  let user interface time address user action =
     None
end


31.6     Module Cyclonity simulation properties
module SimulationProperties =
struct
   let network size = 100
   let end time = 200
   let slow = false
   let latency     = 1.
end
Appendix A

General Utilities

A.1       Module Hash
let hash str =
   if str = "" then
      str
   else
      Digest.string str

let hexa string of string hashed string = Digest.to hex hashed string



A.2       Module Net general
Broken function. Normally, this should return the IP address of the host running the overlay.

let get my addr () =
    (Unix .gethostbyname(Unix .gethostname())).Unix .h addr list.(0)

open socket socket type simply open a socket of a given type (UDP or TCP)

let open socket socket type =
   Unix .socket Unix .PF INET socket type 0

print addr formater socket address pretty-print a value of type Unix.sockaddr

let print addr ppf addr =
   match addr with
     | Unix .ADDR UNIX x →
          Format.fprintf ppf "Addr Unix : %s" x
     | Unix .ADDR INET ( inet addr , port ) →
          Format.fprintf ppf "%s:%d"
            (Unix .string of inet addr inet addr )
            port

signature of addr socket address gives a signature of type Unix.sockaddr

                                                     227
228                                                               APPENDIX A. GENERAL UTILITIES

let signature of addr addr =
   match addr with
      | Unix .ADDR UNIX x →
          "Unix:" ˆ x
      | Unix .ADDR INET ( inet addr , port ) →
          (Unix .string of inet addr inet addr ) ˆ ":" ˆ (string of int port)
write socket data writes the given data on the socket.
   Returns unit option, Some () if succeeds, None otherwise.
let write socket data =
   let data length = String.length data in
   let = Unix .getsockopt int socket Unix .SO ERROR in
   let written = Unix .write socket data 0 data length in
   let error code = Unix .getsockopt int socket Unix .SO ERROR in
      if ( written = data length ∨ error code = 0 ) then
         None
      else
         Some ()
let inet addr of sockaddr s =
   match s with
      | Unix .ADDR UNIX     → failwith "inet addr of sockaddr: given a unix socket"
      | Unix .ADDR INET ( x , ) → x


A.3      Module Tcp
open Net general
Open a TCP connection
let open tcp socket () =
   let socket = open socket Unix .SOCK STREAM in
      Unix .setsockopt socket Unix .SO KEEPALIVE true;
      Unix .setsockopt socket Unix .SO REUSEADDR true;
      socket


A.4      Module Udp
open Net general
Open a UDP connection
let open udp socket () = open socket Unix .SOCK DGRAM


A.5      Module Int to inet
let inet addr of int n =
   let base = ref 256 in
   let n1 = n mod !base in
   let n = n / !base in
A.6. MODULE PRIORITY QUEUE                                                                                229

    if (n = 0) then
       Unix .inet addr of string ("10.0.0." ˆ (string of int n1 ))
    else
       begin
         let n2 = n mod !base in
         let n = n / !base in
            if ( n < 255 ) then
               Unix .inet addr of string ("10." ˆ (string of int n) ˆ "." ˆ (string of int n2 ) ˆ "." ˆ (string of int n1 ))
            else
               failwith "Inet addr of int : host ID too high for a class A network"
       end



A.6        Module Priority queue
module type OrderedType =
sig
   type t
   val print : Format.formatter → t → unit
   val compare : float → t → int
   val get delay : t → float
end

module type S =
sig
   type t
   type queue

  val   create : unit → queue
  val   insert : float → t → queue → queue
  val   remove : t → queue → queue
  val   peek until : float → queue → t list × queue
  val   print queue : Format.formatter → queue → unit
  val   size queue : queue → int
end

module Make ( T : OrderedType ) =
struct




A.7        Types definition
  The working type

  type t = T .t

  queue defines a priority queue type.
230                                                                 APPENDIX A. GENERAL UTILITIES

 type queue =
   | Empty (∗ The terminal leaf ∗)
   | Node of node (∗ A node of the tree ∗)
 and node =
      {
        value : float ; (∗ The priority value of the items, strictly growing over the tree ∗)
        items : t list; (∗ The enqueued elements of scheduled for value − insertion time ∗)
        right : queue (∗ The remaining of the queue : ∀x ∈ node.right, x.value > node.value ∗)
      }
      let size queue queue =
         let rec size queue size queue =
            match queue with
               | Empty → size
               | Node node → size queue (size + List.length node.items) node.right
         in
            size queue 0 queue




A.8       Pretty printer
      print items list formatter items list pretty-prints a list of OrderType values
      let print items list ppf l =
         let rec print list ppf l =
            match l with
               | [] →
                    Format.fprintf ppf ""
               | h :: q →
                    Format.fprintf
                      ppf
                      "%a@ ,@ %a"
                      T .print h
                      print list q
         in
            Format.fprintf
               ppf
               "@[ [@ %a@ ]@]"
               print list l
      print queue formatter queue pretty-prints a queue
      let generic queue printer printer ppf q =
         let rec print queue ppf q =
            match q with
               | Empty →
                   Format.fprintf ppf ""
               | Node node →
                   printer
                      ppf
                      node.value
A.9. CONSTRUCTOR                                                                                      231

                   print items list node.items
                   print queue node.right
      in
           Format.fprintf ppf "@[%a@]" print queue q
   let print queue =
      generic queue printer
        (fun ppf value items printer items queue printer queue →
            Format.fprintf ppf "@[{@ p :@ %f@ ;@ items :@ %a@ }@]@ ->@ %a" value items printer items queue printer
   let signature queue queue =
      generic queue printer
         (fun ppf items printer items queue printer queue →
             Format.fprintf ppf "@[@ items :@ %a@ }@]@ ->@ %a" items printer items queue printer queue)
         Format.str formatter
         queue;
      Format.flush str formatter ()



A.9        Constructor
   create () returns an empty priority queue, ready to use.
   let create () = Empty



A.10        Combinators
   insert current time timed elt queue puts the timed elt into the queue at value current time + timed elt.delay
   let rec insert time t tree =
      match tree with
         | Empty →
             (∗ Hits the end of the queue ∗)
             Node { value = time + . (T .get delay t) ;
                      items = [t] ;
                      right = Empty
                    }
         | Node ( { value = x } as node ) →
             (∗ On a node, compare delays from now : ∗)
             match (T .compare (x − . time) t) with
                | 0 →
                     (∗ x = time + t.delay ∗)
                     Insert right here :
                     Node { value = x ;
                              items = t :: node.items ;
                              right = node.right
                           }
                 | cmp when cmp < 0 →
                     (∗ x ¡ time + t.time ∗)
232                                                                 APPENDIX A. GENERAL UTILITIES

                     Insert depther in the queue :
                     let new right = insert time t node.right in
                        Node { value = x ;
                                items = node.items ;
                                right = new right
                              }
                 |   →
                     (∗ x ¿ time + t.time ∗)
                     Insert befor the given node :
                     Node { value = time + . (T .get delay t) ;
                            items = [t] ;
                            right = Node ( node )
                          }
      remove timed elt queue removes the given timed elt from the queue.
      let rec remove t tree =
         match tree with
            | Empty → Empty
            | Node node →
                let new items , garbage = List.partition ((=) t) node.items in
                   match garbage with
                     | [] →
                          (∗ Nothing removed, go on : ∗)
                          Node
                            {
                              value = node.value ;
                              items = node.items ;
                              right = remove t node.right
                            }
                     |    →
                          (∗ Elt removed, returns : ∗)
                          match new items with
                            | [ ] → node.right
                            |     →
                                  Node
                                    {
                                      value = node.value ;
                                      items = new items ;
                                      right = node.right
                                    }
    peek until absolute time queue peeks all items which were scheduled for a time =¡ absolute time.
Returns a pair of ( items , remaining queue ).
      let rec peek until time tree =
         match tree with
            | Node ( { value = x } as node ) when x ≤ time →
                let items , right = peek until time node.right in
                   ( node.items @ items , right )
            |   → [ ] , tree
A.10. COMBINATORS   233

 end
234   APPENDIX A. GENERAL UTILITIES
Appendix B

Debugger Parser/Lexer

B.1      Module Cli parser (Yacc)


Header

 open Cli ast



Token declarations

%token   EOL
%token   QUIT
%token   OPEN LIST
%token   CLOSE LIST
%token   SEP LIST
%token   <int> INT
   Root commands :
%token   SHOW
%token   STEP
%token   BACKSTEP
%token   HELP
   Depth 2 commands :
%token   NETWORK ROUNDS
%token   PEER
%token   PEERS
%token   TIME
%token   ACTIONS
%token   EVENT
   Depth 3 commands :

                                    235
236                                                   APPENDIX B. DEBUGGER PARSER/LEXER

%token   ALL
%token   NET EVENTS
%token   TIMER EVENTS
%token   USER EVENTS
%token   REGISTRED TIMERS
%token   OPEN PORTS
%token   <int> N INT T INT U INT
%token   STATE
%token <string> WORD
%start main
%type <Cli ast.command > main



Grammar rules

main ::=
| SHOW show EOL { Show $2 }
| STEP step EOL { Step $2 }
| BACKSTEP backstep EOL { Backstep $2 }
| BACKSTEP EOL { Backstep ( Back 1 ) }
| HELP help EOL { Help $2 }
| HELP EOL { Help OnHelp }
| QUIT { Quit }
| EOL { Eol }
show ::=
| NETWORK { NetworkShow }
| PEER INT { PeerShow $2 }
| PEER INT specific { SpecificPeerShow ( $2 , $3 ) }
| PEER INT specific list { SpecificListPeerShow ( $2 , $3 ) }
specific ::=
| ALL { All events }
| NET EVENTS { Net events }
| TIMER EVENTS { Timer events }
| USER EVENTS { User events }
| REGISTRED TIMERS { Registred timers }
| OPEN PORTS { Open ports }
| STATE WORD { State ( $2 ) }
specific list ::=
| OPEN LIST specific SEP LIST specific list { $2 :: $4 }
| specific CLOSE LIST { [ $1 ] }
step ::=
| NETWORK INT ROUNDS { Network $2 }
| PEERS peers list { PeersStepping $2 }
| PEER INT EVENT event selector { PeerStepping ( $2 , $4 ) }
| TIME INT { TimeStepping $2 }
B.2. MODULE CLI LEXER (LEX)                                                        237

peers list ::=
| OPEN LIST INT SEP LIST peers list { $2 :: $4 }
| INT CLOSE LIST { [ $1 ] }
event selector ::=
| ALL { AllEvents }
| N INT { Event ( Pending network , $1) }
| U INT { Event ( Pending user , $1 ) }
| T INT { Event ( Pending timer , $1 ) }
| event list { Events $1 }
event list ::=
| OPEN LIST N         INT SEP LIST event list { ( Pending network , $2 ) :: $4 }
| OPEN LIST T         INT SEP LIST event list { ( Pending timer , $2 ) :: $4 }
| OPEN LIST U         INT SEP LIST event list { ( Pending user , $2 ) :: $4 }
| N INT CLOSE         LIST { [ ( Pending network , $1 ) ] }
| U INT CLOSE         LIST { [ ( Pending user , $1 ) ] }
| T INT CLOSE         LIST { [ ( Pending timer , $1 ) ] }
backstep ::=
| INT ACTIONS { Back $1 }
help ::=
| SHOW { OnShow AllHelpShow }
| SHOW help show selector { OnShow $2 }
| STEP { OnStep AllHelpStep }
| STEP help step selector { OnStep $2 }
| BACKSTEP { OnBack AllHelpBack }
help step selector ::=
| NETWORK { OnNetwork }
| PEERS { OnPeers }
| PEER { OnPeer }
| TIME { OnTime }
help show selector ::=
| NETWORK { HelpShowOnNetwork }
| PEER { HelpShowOnPeer AllHelpShowPeer }
| PEER help show peer selector { HelpShowOnPeer $2 }
help show peer selector ::=
| NET EVENTS { OnNetEvents }
| TIMER EVENTS { OnTimerEvents }
| USER EVENTS { OnUserEvents }
| REGISTRED TIMERS { OnRegistredTimers }
| OPEN PORTS { OnOpenPorts }
| STATE { OnState }


B.2       Module Cli lexer (Lex)
{
    open Cli parser
}
238                                                      APPENDIX B. DEBUGGER PARSER/LEXER

rule   lexer = parse
   |   [ ’ ’ ] { lexer lexbuf }
   |   ’[’ { OPEN LIST }
   |   ’;’ { SEP LIST }
   |   ’]’ { CLOSE LIST }
   |   "show" { SHOW }
   |   "sh" { SHOW }
   |   "step" { STEP }
   |   "st" { STEP }
   |   "backstep" { BACKSTEP }
   |   "bs" { BACKSTEP }
   |   "help" { HELP }
   |   "h" { HELP }
   |   "network" { NETWORK }
   |   "net" { NETWORK }
   |   "rounds" { ROUNDS }
   |   "rds" { ROUNDS }
   |   "peer" { PEER }
   |   "p" { PEER }
   |   "peers" { PEERS }
   |   "ps" { PEERS }
   |   "actions" { ACTIONS }
   |   "a" { ACTIONS }
   |   "event" { EVENT }
   |   "e" { EVENT }
   |   "all" { ALL }
   |   "net events" { NET EVENTS }
   |   "ne" { NET EVENTS }
   |   "timer events" { TIMER EVENTS }
   |   "te" { TIMER EVENTS }
   |   "user events" { USER EVENTS }
   |   "ue" { USER EVENTS }
   |   "registred timers" { REGISTRED TIMERS }
   |   "rt" { REGISTRED TIMERS }
   |   "open ports" { OPEN PORTS }
   |   "op" { OPEN PORTS }
   |   "time" { TIME }
   |   "ti" { TIME }
   |   ’n’ ( [’0’ – ’9’]+ as lxm ) { N INT (int of string lxm) }
   |   ’t’ ( [’0’ – ’9’]+ as lxm ) { T INT (int of string lxm) }
   |   ’u’ ( [’0’ – ’9’]+ as lxm ) { U INT (int of string lxm) }
   |   "state" { STATE }
   |   "s" { STATE }
   |   "quit" { QUIT }
   |   [’0’ – ’9’]+ as lxm { INT (int of string lxm) }
   |   [ ’a’ – ’z’ ] [ ’a’ – ’z’ ’A’ – ’Z’ ’0’ – ’9’ ’_’ ]+ as lxm { WORD ( lxm ) }
   |   [ ’\n’ ] { EOL }
   |   eof { EOL }

				
DOCUMENT INFO
Shared By:
Categories:
Tags:
Stats:
views:12
posted:7/27/2011
language:English
pages:238