Source file `ed.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
121
122
123
124
125
126
127
128
129
130
131
132
(*********************************************************************************)
(*                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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** *)

module S = Cohttp_lwt_unix.Server
module J = Yojson.Safe
open Stog.Url

let (>>=) = Lwt.bind

module Server_P = struct
  include Ojs_base.Rpc.Base(Stog_multi_ed_common.Types.App_msg)
  let wsdata_of_msg msg = J.to_string (Stog_multi_ed_common.Types.server_msg_to_yojson msg)
  let msg_of_wsdata = Ojs_server.Server.mk_msg_of_wsdata Stog_multi_ed_common.Types.client_msg_of_yojson
  end
module Server = Ojs_server.Server.Make(Server_P)
module SFT = Ojs_filetree_server.Server.Make(Stog_multi_ed_common.Types.FT)
module SED = Ojs_ed_server.Server.Make(Stog_multi_ed_common.Types.ED)
module Git = Git_server.Make(Stog_multi_ed_common.Types.Git)

(*
class myft broadcall broadcast ~id root =
  object(self)
    inherit SFT.filetree broadcall broadcast ~id root as super
    method handle_message msg =
      prerr_endline "message!";
      super#handle_message msg
  end
*)


let init ?sshkey ~stog_dir ~git () =
  let connections = new Server.connection_group in
  let filetrees = new SFT.filetrees connections#broadcall connections#broadcast
    (new SFT.filetree)
  in
  let editors = new SED.editors connections#broadcall connections#broadcast
    (new SED.editor)
  in
  let git_repos = new Git.repos connections#broadcall connections#broadcast
    (new Git.repo)
  in
  let _ft = filetrees#add_filetree Stog_multi_ed_common.Types.ft_id stog_dir in
  let _ed = editors#add_editor Stog_multi_ed_common.Types.ed_id stog_dir in
  let _repo = git_repos#add_repo ~id: Stog_multi_ed_common.Types.gitrepo_id ?sshkey git in
  let handle_message send_msg rpc msg =
    match msg with
    | Stog_multi_ed_common.Types.ED.Editor _ -> editors#handle_message send_msg msg
    | Stog_multi_ed_common.Types.FT.Filetree _ -> filetrees#handle_message send_msg msg
    | Stog_multi_ed_common.Types.Git.Git _ -> git_repos#handle_message send_msg msg
    | Server_P.Call (call_id, ((Stog_multi_ed_common.Types.FT.Filetree _) as msg))->
        let return msg = Server.Rpc.return rpc call_id msg in
        filetrees#handle_call return msg
    | Server_P.Call (call_id, ((Stog_multi_ed_common.Types.ED.Editor _) as msg)) ->
        let return msg = Server.Rpc.return rpc call_id msg in
        editors#handle_call return msg
    | Server_P.Call (call_id, ((Stog_multi_ed_common.Types.Git.Git _) as msg)) ->
        let return msg = Server.Rpc.return rpc call_id msg in
        git_repos#handle_call return msg
    | _ ->
        let str = Printf.sprintf
          "Unhandled message (Stog_multi_ed.handle_message): %s"
          (Printexc.to_string (Obj.magic msg))
        in
        failwith str
  in
  connections#set_handle_message handle_message;
  connections

let body_tmpl = [%xtmpl "templates/multi_ed.tmpl"]
let page cfg user ~ws_url ~title ~client_js_url =
  let client_js_url = Stog.Url.to_string client_js_url in
  let js = [ "stog_server = { wsUrl: '"^(Stog.Url.to_string ws_url)^"' } ;" ] in
  let body = body_tmpl
    ~client_js_url
    ~ft_id: Stog_multi_ed_common.Types.ft_id
      ~ojs_msg_id: Stog_multi_ed_common.Types.ojs_msg_id
      ~bar_id: Stog_multi_ed_common.Types.bar_id
      ~git_id: Stog_multi_ed_common.Types.gitrepo_id
      ~ed_id: Stog_multi_ed_common.Types.ed_id
      ()
  in
  Page.page cfg user ~empty: true ~title ~js body

let client_js = "stog_multi_ed.js"
let client_js_content = [%blob "stog_multi_ed_js.bc.js"]

let editor_page cfg user ~http_url ~ws_url base_path session_id =
  let client_js_path = base_path @ [ "editor" ; client_js ] in
  (* FIXME: port number when we will be able to change an
    http connection into a websocket one manually *)
  let client_js_url = Stog.Url.append http_url.pub client_js_path in
  let ws_url = Stog.Url.append ws_url.pub (base_path @ ["editor"]) in
  let title = Printf.sprintf "Session %S" session_id in
  page cfg (Some user) ~ws_url ~title ~client_js_url

let http_handler cfg user ~http_url ~ws_url base_path session_id req body = function
| [s] when s = client_js ->
    Stog_server.Preview.respond_js client_js_content
| [] | [""] ->
    let body = editor_page cfg user ~http_url ~ws_url base_path session_id in
    let body = Xtmpl.Rewrite.to_string body in
    S.respond_string ~status: `OK ~body ()
| _ ->
    S.respond_error ~status:`Not_found ~body: "" ()