Browse Source

use data-encoding

trunk
Swrup 10 months ago
parent
commit
a75540b2f5
  1. 2
      .ocamlformat
  2. 24
      src/dromloc.ml
  3. 3
      src/dune
  4. 18
      src/js/client.ml
  5. 54
      src/msg.ml
  6. 3
      test/dune
  7. 14
      test/test.ml

2
.ocamlformat

@ -1,4 +1,4 @@
version=0.24.1
version=0.25.1
assignment-operator=end-line
break-cases=fit
break-fun-decl=wrap

24
src/dromloc.ml

@ -64,18 +64,24 @@ let handle_client request client =
Hashtbl.add room id client;
let rec loop () =
match%lwt Dream.receive client with
| Some data ->
(* TODO check geo and catch marshal failure *)
let s = Scanf.sscanf data "%S" (fun s -> s) in
let pos_magic : Msg.Magic.t = Marshal.from_string s 0 in
let pos = Msg.Magic.to_pos pos_magic in
let msg : Msg.server_msg = (id, Msg.Magic.of_pos pos) in
let s = Marshal.to_string msg [] |> Format.sprintf "%S" in
let* () = send room s in
loop ()
| None ->
forget_client room id;
Dream.close_websocket client
| Some data -> (
let s = Scanf.sscanf data "%S" (fun s -> s) in
let message_to_broadcast_res =
Result.bind (Msg.decode_pos s) (fun pos ->
Result.map
(fun s -> Format.sprintf "%S" s)
(Msg.encode_pos_with_id (id, pos)) )
in
match message_to_broadcast_res with
| Error e ->
Dream.log "Error in encoding/decoding message: %s" e;
failwith e
| Ok s ->
let* () = send room s in
loop () )
in
loop ()

3
src/dune

@ -2,6 +2,7 @@
(name dromloc)
(modules app content dromloc home util template room)
(libraries
data-encoding
uuidm
bos
caqti
@ -25,7 +26,7 @@
(library
(name msg)
(modules msg)
(libraries))
(libraries data-encoding))
(rule
(target content.ml)

18
src/js/client.ml

@ -39,12 +39,12 @@ let () =
let on_open _e =
let send jv_geo =
log "send msg ~~ @\n";
let msg : Msg.Magic.t = Msg.Magic.of_pos @@ jv_to_pos jv_geo in
let s = Marshal.to_string msg [] in
let s = Format.sprintf "%S" s |> Jstr.of_string in
Websocket.send_string ws s;
log "msg was send to websocket ~~ @\n";
()
match Msg.encode_pos (jv_to_pos jv_geo) with
| Error e -> failwith e
| Ok s ->
let s = Format.sprintf "%S" s |> Jstr.of_string in
Websocket.send_string ws s;
log "msg was send to websocket ~~ @\n"
in
let _watch_id = Geo.watch_geolocation send in
()
@ -91,13 +91,11 @@ end
let () =
let on_message m =
log " on_message@\n";
let (id, magic_pos) : Msg.server_msg =
let id, pos =
let data = Message.Ev.data (Ev.as_type m) |> Jstr.to_string in
let s = Scanf.sscanf data "%S" (fun s -> s) in
Marshal.from_string s 0
match Msg.decode_pos_with_id s with Error e -> failwith e | Ok v -> v
in
log "un-marshaled message from server @\n";
let pos = Msg.Magic.to_pos magic_pos in
match Camel.find_opt id with
| None -> Camel.add id pos
| Some friend -> Camel.move_to pos friend

54
src/msg.ml

@ -1,4 +1,3 @@
(* :^) *)
type pos =
{ latitude : float
; longitude : float
@ -8,7 +7,7 @@ type pos =
let pos_to_string pos =
Format.sprintf
{|
{|
{ latitude = %f
; longitude = %f
; accuracy = %f
@ -16,33 +15,38 @@ let pos_to_string pos =
}|}
pos.latitude pos.longitude pos.accuracy pos.timestamp_ms
module Magic : sig
type t
open Data_encoding
val of_pos : pos -> t
let pos_to_tuple { latitude; longitude; accuracy; timestamp_ms } =
(latitude, longitude, accuracy, timestamp_ms)
val to_pos : t -> pos
end = struct
open Bigarray
let tuple_to_pos (latitude, longitude, accuracy, timestamp_ms) =
{ latitude; longitude; accuracy; timestamp_ms }
type t = (float, float64_elt, c_layout) Array1.t
let pos_encoding = conv pos_to_tuple tuple_to_pos (tup4 float float float float)
let of_pos { latitude; longitude; accuracy; timestamp_ms } =
let arr = Array1.create Float64 C_layout 4 in
Array1.set arr 0 latitude;
Array1.set arr 1 longitude;
Array1.set arr 2 accuracy;
Array1.set arr 3 timestamp_ms;
arr
let pos_with_id_encoding = tup2 string pos_encoding
let to_pos arr =
{ latitude = Array1.get arr 0
; longitude = Array1.get arr 1
; accuracy = Array1.get arr 2
; timestamp_ms = Array1.get arr 3
}
end
let encode_pos v =
Result.map_error
(fun e -> Format.asprintf "Failed to encode pos: %a" Binary.pp_write_error e)
(Binary.to_string pos_encoding v)
type client_msg = Magic.t
let encode_pos_with_id v =
Result.map_error
(fun e ->
Format.asprintf "Failed to encode pos with id: %a" Binary.pp_write_error e
)
(Binary.to_string pos_with_id_encoding v)
type server_msg = string * Magic.t
let decode_pos v =
Result.map_error
(fun e -> Format.asprintf "Failed to decode pos: %a" Binary.pp_read_error e)
(Binary.of_string pos_encoding v)
let decode_pos_with_id v =
Result.map_error
(fun e ->
Format.asprintf "Failed to decode pos with id: %a" Binary.pp_read_error e
)
(Binary.of_string pos_with_id_encoding v)

3
test/dune

@ -1,3 +1,4 @@
(test
(name test)
(modules test))
(modules test)
(libraries msg))

14
test/test.ml

@ -1 +1,13 @@
let () = assert true (* TODO *)
(* test data-encoding *)
let () =
let v =
Msg.
{ latitude = 8.0; longitude = 0.6; accuracy = 10.1; timestamp_ms = 3.02 }
in
let j = Msg.encode_pos v |> Result.get_ok in
let w = Msg.decode_pos j |> Result.get_ok in
assert (v = w);
let vv = ("Kurapika", v) in
let jj = Msg.encode_pos_with_id vv |> Result.get_ok in
let ww = Msg.decode_pos_with_id jj |> Result.get_ok in
assert (vv = ww)

Loading…
Cancel
Save