1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
(** *)
open Ojs_server.Server
module type S = sig
module P : Ojs_ed.Types.P
val access_forbidden : Ojs_base.Path.t -> P.server_msg
class editor :
(P.server_msg -> (P.client_msg -> unit Lwt.t) -> unit Lwt.t) ->
(P.server_msg -> unit Lwt.t) ->
id:string ->
Ojs_base.Path.t ->
object
method can_read_file : string -> bool
method can_write_file : string -> bool
method handle_call :
(P.server_msg -> unit Lwt.t) -> P.client_msg -> unit Lwt.t
method handle_get_file_contents :
(P.server_msg -> unit Lwt.t) -> Ojs_ed.Types.path -> unit Lwt.t
method handle_message :
(P.server_msg -> unit Lwt.t) -> P.client_msg -> unit Lwt.t
method handle_save_file :
(P.server_msg -> unit Lwt.t) ->
Ojs_ed.Types.path -> string -> unit Lwt.t
method id : string
method root : Ojs_base.Path.t
end
class editors :
(P.app_server_msg -> (P.app_client_msg -> unit Lwt.t) -> unit Lwt.t) ->
(P.app_server_msg -> unit Lwt.t) ->
((P.server_msg -> (P.client_msg -> unit Lwt.t) -> unit Lwt.t) ->
(P.server_msg -> unit Lwt.t) -> id:string -> Ojs_base.Path.t -> editor) ->
object
val mutable editors : editor Ojs_server.Server.SMap.t
method add_editor : id:Ojs_server.Server.SMap.key -> Ojs_base.Path.t -> editor
method editor : Ojs_server.Server.SMap.key -> editor
method handle_call :
(P.app_server_msg -> unit Lwt.t) ->
P.app_client_msg -> unit Lwt.t
method handle_message :
(P.app_server_msg -> unit Lwt.t) ->
P.app_client_msg -> unit Lwt.t
end
end
module Make (P: Ojs_ed.Types.P) =
struct
module P = P
let access_forbidden path =
P.SError ("Forbidden access to "^(Ojs_base.Path.to_string path))
class editor
(broadcall : P.server_msg -> (P.client_msg -> unit Lwt.t) -> unit Lwt.t)
(broadcast : P.server_msg -> unit Lwt.t) ~id root =
object(self)
method id = (id : string)
method root = (root : Ojs_base.Path.t)
method can_read_file file = true
method can_write_file file = true
method handle_get_file_contents reply_msg path =
let norm =
let path = Ojs_base.Path.append_path root path in
Ojs_base.Path.normalize path
in
let file = Ojs_base.Path.to_string norm in
match self#can_read_file file with
| false -> reply_msg (access_forbidden path)
| true ->
let contents = Files.string_of_file file in
reply_msg (P.SFile_contents (path, contents))
method handle_save_file reply_msg path contents =
let norm =
let path = Ojs_base.Path.append_path root path in
Ojs_base.Path.normalize path
in
let file = Ojs_base.Path.to_string norm in
match self#can_write_file file with
| false -> reply_msg (access_forbidden path)
| true ->
Files.file_of_string ~file contents ;
reply_msg (P.SOk (Printf.sprintf "File %S saved" (Ojs_base.Path.to_string path)))
method handle_message
(send_msg : P.server_msg -> unit Lwt.t) (msg : P.client_msg) =
self#handle_call send_msg msg
method handle_call
(reply_msg : P.server_msg -> unit Lwt.t) (msg : P.client_msg) =
match msg with
| P.Get_file_contents path ->
self#handle_get_file_contents reply_msg path
| P.Save_file (path, contents) ->
self#handle_save_file reply_msg path contents
| _ ->
reply_msg (P.SError "Unhandled message")
end
class editors
(broadcall : P.app_server_msg -> (P.app_client_msg -> unit Lwt.t) -> unit Lwt.t)
(broadcast : P.app_server_msg -> unit Lwt.t)
(spawn : (P.server_msg -> (P.client_msg -> unit Lwt.t) -> unit Lwt.t) ->
(P.server_msg -> unit Lwt.t) ->
id: string -> Ojs_base.Path.t -> editor
)
=
object(self)
val mutable editors = (SMap.empty : editor SMap.t)
method editor id =
try SMap.find id editors
with Not_found -> failwith (Printf.sprintf "No editor with id %S" id)
method add_editor ~id root =
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 ed = spawn broadcall broadcast ~id root in
editors <- SMap.add id ed editors;
ed
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#editor 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#editor id)#handle_call reply_msg msg
| None -> Lwt.return_unit
end
end