1. Dmitry Grebeniuk
  2. amall

Commits

Dmitry Grebeniuk  committed 76e3396

on websockets

  • Participants
  • Parent commits 9dd4206
  • Branches default

Comments (0)

Files changed (4)

File _oasis

View file
  • Ignore whitespace
   Install: false
   CompiledObject: best
   MainIs: test_websocket_service.ml
-  BuildDepends: iteratees, monad_io.lwt, cadastr, cryptokit
+  BuildDepends: iteratees, monad_io.lwt, cadastr, cryptokit, cadastr.json
   NativeOpt:       -w A
   ByteOpt:         -w A
 

File _tags

View file
  • Ignore whitespace
 # OASIS_START
-# DO NOT EDIT (digest: 7af2c34c29b8144ccf97ac7f16e97c3c)
+# DO NOT EDIT (digest: 44fd8523ebb5be5f5ce5d4ee0525938a)
 # Ignore VCS directories, you can use the same kind of rule outside 
 # OASIS_START/STOP if you want to exclude directories that contains 
 # useless stuff for the build process
 <tests/test_websocket_service.{native,byte}>: pkg_monad_io.lwt
 <tests/test_websocket_service.{native,byte}>: pkg_iteratees
 <tests/test_websocket_service.{native,byte}>: pkg_cryptokit
+<tests/test_websocket_service.{native,byte}>: pkg_cadastr.json
 <tests/test_websocket_service.{native,byte}>: pkg_cadastr
+<tests/*.ml{,i}>: pkg_cadastr.json
 # Executable test_http_service
 <tests/test_http_service.{native,byte}>: oasis_executable_test_http_service_byte
 <tests/*.ml{,i}>: oasis_executable_test_http_service_byte

File setup.ml

View file
  • Ignore whitespace
 (* setup.ml generated for the first time by OASIS v0.2.1~alpha1 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 5793a4b87d4efd967f9c3710724ec779) *)
+(* DO NOT EDIT (digest: 7bf7ffa4b9475161ea20d40f268b84ae) *)
 (*
    Regenerated by OASIS v0.2.1~alpha1
    Visit http://oasis.forge.ocamlcore.org for more information and
                            FindlibPackage ("iteratees", None);
                            FindlibPackage ("monad_io.lwt", None);
                            FindlibPackage ("cadastr", None);
-                           FindlibPackage ("cryptokit", None)
+                           FindlibPackage ("cryptokit", None);
+                           FindlibPackage ("cadastr.json", None)
                         ];
                       bs_build_tools = [ExternalTool "ocamlbuild"];
                       bs_c_sources = [];

File tests/test_websocket_service.ml

View file
  • Ignore whitespace
 
 open I.Ops;
 
+value srv_num = ref 0;
+
+
+type in_msg =
+  [= `Chat of string
+  ]
+;
+
+type chat_out_msg =
+  { com_text : string
+  ; com_dt : int
+  }
+;
+
+type out_msg =
+  [= `Chat of chat_out_msg
+  |  `Error of string
+  ]
+;
+
+open Cdt
+;
+
+value ti_in_msg : #ti in_msg = new ti_sum_type
+  ~constr:
+  [| ti_ctr_variant1 "chat" ti_string & fun s -> `Chat s |]
+  (fun _ -> failwith "not destructible")
+;
+
+value ti_chat_out_msg : #ti chat_out_msg = new ti_record
+  (fun [ { com_text ; com_dt } ->
+     [| ("text", ubox ti_string com_text)
+      ; ("dt", ubox ti_int com_dt)
+      |]
+   ]
+  )
+;
+
+value ti_out_msg : #ti out_msg = new ti_sum_type
+  (fun
+   [ `Chat com -> ti_variant "chat" [| ubox ti_chat_out_msg com |]
+   | `Error str -> ti_variant "error" [| ubox ti_string str |]
+   ]
+  )
+;
+
+value () =
+  let open Cd_Json in
+  ( ti_add_json ti_in_msg ()
+  ; ti_add_json ti_chat_out_msg ()
+  ; ti_add_json ti_out_msg ()
+  )
+;
+
+
+value clients : Hashtbl.t int Ws.ws_out_socket = Hashtbl.create 17
+;
+
+
 value my_func = Partapp3.make
   (fun segpath _rq outws ->
      let txt = sprintf "[%s]" &
        List.map (sprintf "%S") &
        segpath
      in
-     let () = dbg "service: got websocket request on %s" txt in
+     let n = srv_num.val in let () = incr srv_num in
+     let () = dbg "service: [%i] got websocket request on %s" n txt in
+     let () = Hashtbl.add clients n outws in
      fun opcode_in ->
-       let () = dbg "service: entering" in
+       let () = dbg "service: [%i] entering" n in
        match opcode_in with
        [ `Text ->
            I.gather_to_string >>= fun s ->
-           let () = dbg "service: got text frame: %S" s in
-           Ws.it_close outws (Some 7777) >>= fun () ->
+           let () = dbg "service: [%i] got text frame: %S" n s in
+           I.lift
+             (IO.catch
+                (fun () ->
+                   let in_msg = Cd_Json.from_json_string ti_in_msg s in
+                   match in_msg with
+                   [ `Chat text ->
+                       let om = `Chat
+                         { com_text = text
+                         ; com_dt = int_of_float (Unix.time ())
+                         }
+                       in
+                       let om_txt = Cd_Json.to_json_string ti_out_msg om in
+                       let () = Hashtbl.iter
+                         (fun sn s ->
+                            IO.run_and_ignore_result
+                              (if Ws.is_close_sent s
+                               then
+                                 IO.return ()
+                               else
+                                 let () = dbg "service: [%i]: send msg to %i"
+                                 n sn in
+                                 Ws.send s `Text om_txt
+                              )
+                         )
+                         clients
+                       in
+                         IO.return ()
+                   ]
+                )
+                (let send_error msg =
+                   Ws.send outws `Text &
+                   Cd_Json.to_json_string ti_out_msg &
+                   `Error msg
+                 in
+                 fun
+                 [ Cd_Json.Jt.Json_error msg ->
+                     send_error & "json error: " ^ msg
+                 | e ->
+                     send_error & Printexc.to_string e
+                 ]
+                )
+             ) >>= fun () ->
            I.return ()
        | `Close opt_code ->
-           let () = dbg "service: got `Close (%s)"
+           let () = dbg "service: [%i] got `Close (%s)" n
              (match opt_code with
               [ None -> "None"
               | Some c -> sprintf "Some %i" c
               ]
              )
            in
+           let () = Hashtbl.remove clients n in
            Ws.it_close outws opt_code
        | _ ->
            I.gather_to_string >>= fun s ->
-           let () = dbg "service: got non-text non-close frame: %S" s in
+           let () = dbg "service: [%i] got non-text non-close frame: %S" n s in
            I.return ()
        ]
   )