Source file `server.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
(*********************************************************************************)
(*                Ojs-base                                                       *)
(*                                                                               *)
(*    Copyright (C) 2014-2021 INRIA. All rights reserved.                        *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the               *)
(*    GNU Library General Public License for more details.                       *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Handling lists on server side. *)

open Ojs_server.Server

let (>>=) = Lwt.(>>=)

module Make (P : Ojs_list.Types.P) =
  struct
    class ['a] elist
      (broadcall : 'a P.server_msg -> ('a P.client_msg -> unit Lwt.t) -> unit Lwt.t)
        (broadcast : 'a P.server_msg -> unit Lwt.t) ~id init =
        object(self)
          val mutable list = (init : 'a list)
          method list = list
          method set_list l = list <- l ; broadcast (P.SList l)

          method id = (id : string)

          method handle_add reply x =
            list <- x :: list;
            reply P.SOk >>= fun _ -> broadcast (P.SAdd x)

          method handle_delete reply x =
            list <- List.filter ((<>) x) list;
            reply P.SOk >>= fun _ -> broadcast (P.SAdd x)

          method handle_get reply = reply (P.SList list)

          method handle_message (send_msg : 'a P.server_msg -> unit Lwt.t) (msg : 'a P.client_msg) =
            self#handle_call send_msg msg

          method handle_call (reply_msg : 'a P.server_msg -> unit Lwt.t) (msg : 'a P.client_msg) =
            match msg with
            | P.Get -> self#handle_get reply_msg
            | P.Add x -> self#handle_add reply_msg x
            | P.Delete x -> self#handle_delete reply_msg x
            | _ -> failwith "List: Unhandled message"

        end

    class ['a] elists broadcall broadcast spawn
(*      (broadcall : (string * 'a P.server_msg) P.msg ->
         ((string * 'a P.client_msg) P.msg -> unit Lwt.t) -> unit Lwt.t)
        (broadcast : (string * 'a P.server_msg) P.msg -> unit Lwt.t)
        (spawn : ('a P.server_msg -> ('a P.client_msg -> unit Lwt.t) -> unit Lwt.t) ->
         ('a P.server_msg -> unit Lwt.t) ->
           id: string -> 'a list -> 'a elist
        )*)
        =
        object(self)
          val mutable lists = (SMap.empty : 'a elist SMap.t)

          method list id =
            try SMap.find id lists
            with Not_found -> failwith (Printf.sprintf "No list with id %S" id)

          method add_list ~id (init : 'a list) =
            let broadcall msg cb =
              let cb msg =
                match P.unpack_client_msg msg with
                | Some (_, msg) -> cb msg
                | None -> Lwt.return_unit
              in
              broadcall (P.pack_server_msg id msg) cb
            in
            let broadcast msg = broadcast (P.pack_server_msg id msg) in
            let elist = spawn broadcall broadcast ~id init in
            lists <- SMap.add id elist lists;
            elist

          method handle_message
            (send_msg : P.app_server_msg -> unit Lwt.t)
              (msg : P.app_client_msg) =
              match P.unpack_client_msg msg with
              | Some (id, msg) ->
                  let send_msg msg = send_msg (P.pack_server_msg id msg) in
                  (self#list id)#handle_message send_msg msg
              | None -> Lwt.return_unit

          method handle_call
            (return : P.app_server_msg -> unit Lwt.t)
              (msg : P.app_client_msg) =
              match P.unpack_client_msg msg with
              | Some (id, msg) ->
                  let reply_msg msg = return (P.pack_server_msg id msg) in
                  (self#list id)#handle_call reply_msg msg
              | None -> Lwt.return_unit
        end
  end