Source file `ws.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
(*********************************************************************************)
(*                Stog                                                           *)
(*                                                                               *)
(*    Copyright (C) 2012-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    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 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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** *)


open Stog.Url
open Config
open Session
open Gs

let (>>=) = Lwt.bind

let handle_con gs base_path client =
  prerr_endline "new connection";
  let recv () = Websocket_lwt_unix.Connected_client.recv client in
  let push = Websocket_lwt_unix.Connected_client.send client in
  let req = Websocket_lwt_unix.Connected_client.http_request client in
  let stream = Websocket_lwt_unix.mk_frame_stream recv in
  let uri = Cohttp.Request.uri req in
  let path = Stog_base.Misc.split_string (Uri.path uri) ['/'] in
  match path with
  | "sessions" :: id :: p ->
      begin
        match Stog.Types.Str_map.find id !(gs.sessions) with
        | exception Not_found ->
            failwith (Printf.sprintf "Invalid session %S" id)
        | session ->
            match p with
            | "editor" :: _ ->
                session.session_editor.editor_ws_cons#add_connection stream push
            | _ ->
                session.session_stog.stog_ws_cons := (stream, push) :: !(session.session_stog.stog_ws_cons) ;
                let read_stog () = Session.read_stog session.session_stog.stog_dir in
                Stog_server.Ws.handle_messages read_stog
                  session.session_stog.stog_state session.session_stog.stog_ws_cons (base_path @ [id])
                  stream push
      end
  | _ -> failwith "Invalid path"

;;

let server cfg gs sockaddr =
  Websocket_lwt_unix.establish_standard_server
    ~check_request:(fun _ -> true)

;;

let run_server cfg gs =
  let host = Stog.Url.host cfg.ws_url.priv in
  let port = Stog.Url.port cfg.ws_url.priv in
  prerr_endline ("Setting up websocket server on host="^host^", port="^(string_of_int port));
  (* set scheme to http to be resolved correctly *)
  let uri =
    let u = Uri.of_string (Stog.Url.to_string cfg.ws_url.priv) in
    Uri.with_scheme u (Some "http")
  in
  Resolver_lwt.resolve_uri ~uri Resolver_lwt_unix.system >>= fun endp ->
  let ctx = Lazy.force Conduit_lwt_unix.default_ctx in
  Conduit_lwt_unix.endp_to_server ~ctx endp >>= fun server ->
  let handler = handle_con gs (Stog.Url.path cfg.ws_url.pub) in
  Websocket_lwt_unix.establish_standard_server ~ctx
    ~check_request:(fun _ -> true)
    ~mode: server handler
;;