do not send whole state on action

src/island_client.ml

@@ -51,11 +51,12 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up")
 
 let water = C2d.image_src_of_el (get_el "water")
 
-let draw_map =
+let draw =
   let papy_x = float_of_int (width - tile_size) /. 2. in
   let papy_y = (float_of_int height /. 2.) -. (float_of_int tile_size *. 1.5) in
-  fun map ->
-    let player_x, player_y = map.Map.player_pos in
+  fun state ->
+    let open State in
+    let player_x, player_y, player_dir = state.player_pos in
     for x = 0 to tiles_per_w - 1 do
       let map_x = x + player_x - (tiles_per_w / 2) in
       let tile_x = float_of_int ((x * tile_size) + orig_x) in
@@ -63,7 +64,7 @@ let draw_map =
         let map_y = y + player_y - (tiles_per_h / 2) in
         let tile_y = float_of_int ((y * tile_size) + orig_y) in
         let tile_img =
-          match Map.get_tile_kind ~x:map_x ~y:map_y map with
+          match Map.get_tile_kind ~x:map_x ~y:map_y state.map with
           | Grass -> grass
           | Water -> water
           | Black -> water
@@ -72,7 +73,7 @@ let draw_map =
       done
     done;
     let papy =
-      match map.Map.player_dir with
+      match player_dir with
       | Left -> papy_left
       | Right -> papy_right
       | Down -> papy_down
@@ -80,19 +81,43 @@ let draw_map =
     in
     C2d.draw_image context papy ~x:papy_x ~y:papy_y
 
-let kb_handler state ev =
-  let move = Map.move !state.State.map in
-  match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with
-  | "KeyW" | "ArrowUp" -> move Up
-  | "KeyA" | "ArrowLeft" -> move Left
-  | "KeyS" | "ArrowDown" -> move Down
-  | "KeyD" | "ArrowRight" -> move Right
-  | "KeyM" -> Ws_client.send State.Meditate
-  | _s -> ()
+(* queue for action to be done *)
+let input_queue = Queue.create ()
+
+(* queue for action' to apply to client state *)
+let to_apply_queue : State.action' Queue.t = Queue.create ()
+
+let send_action state action =
+  match State.check_action state action with
+  | Error e -> Format.printf "Invalid action: %s@\n" e
+  | Ok _ -> Ws_client.send (Network.Action_msg action)
+
+let kb_handler ev =
+  let open State in
+  let act =
+    match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with
+    | "KeyW" | "ArrowUp" -> Move Up
+    | "KeyA" | "ArrowLeft" -> Move Left
+    | "KeyS" | "ArrowDown" -> Move Down
+    | "KeyD" | "ArrowRight" -> Move Right
+    | "KeyM" -> Meditate
+    | _s -> Do_nothing
+  in
+  Queue.add act input_queue
 
 let rec game_loop state _timestamp =
-  draw_map !state.State.map;
-  let new_state = state in
+  draw state;
+  let new_state =
+    (* TODO repesct order of action *)
+    (* apply to_apply_queue *)
+    let state = Queue.fold State.perform_action state to_apply_queue in
+    (* TODO can this bug because of concurrency? *)
+    Queue.clear to_apply_queue;
+    (* send input action to server *)
+    Queue.iter (send_action state) input_queue;
+    Queue.clear input_queue;
+    state
+  in
   G.request_animation_frame (game_loop new_state)
 
 let () =
@@ -106,16 +131,27 @@ let () =
   (* get state from server*)
   let initial_state_fut = Ev.next Message.Ev.message Ws_client.ws_target in
 
+  (* attach message listener to update state *)
+  Ws_client.on_update_state_message (fun server_msg ->
+      match server_msg with
+      | Full_state _state ->
+        (* TODO reset state to received state *)
+        Format.printf "received Full_state message@\n"
+      | Update_result res -> (
+        match res with
+        | Error e -> Format.printf "received update result error: %s" e
+        | Ok action' -> Queue.add action' to_apply_queue ) );
+  (* bind keys *)
+  let _e : Ev.listener =
+    Ev.listen Ev.keydown kb_handler (Window.as_target G.window)
+  in
+
   Fut.await initial_state_fut (fun msg ->
-      let initial_state = Ws_client.to_server_msg msg in
-      let state_ref = ref initial_state in
-      (* bind keys *)
-      let _e : Ev.listener =
-        Ev.listen Ev.keydown (kb_handler state_ref) (Window.as_target G.window)
-      in
-      (* attach message listener to update state *)
-      Ws_client.on_update_state_message (fun received ->
-          state_ref := received;
-          Format.printf "YOUR MANA IS: %d@." !state_ref.mana );
-      (* start game *)
-      G.request_animation_frame (game_loop state_ref) )
+      match Ws_client.to_server_msg msg with
+      | Update_result _res_msg ->
+        failwith
+          "invalid first server message received; received Update expected \
+           Full_state"
+      | Full_state state ->
+        (* start game *)
+        G.request_animation_frame (game_loop state) )

src/map.ml

@@ -9,10 +9,10 @@ type background =
   | Water
   | Black
 
+type position = int * int * dir
+
 type t =
   { tiles : background array array
-  ; mutable player_pos : int * int
-  ; mutable player_dir : dir
   ; width : int
   ; height : int
   }
@@ -25,23 +25,22 @@ let init () =
         Array.init height (fun _y ->
             if Random.int 1000 <= 42 then Water else Grass ) )
   in
-  { tiles; player_pos = (20, 3); player_dir = Down; width; height }
+  { tiles; width; height }
 
 let get_tile_kind ~x ~y map =
   try map.tiles.(x).(y) with Invalid_argument _ -> Black
 
-let move map dir =
-  if map.player_dir = dir then begin
-    let x, y = map.player_pos in
-    let x, y =
+let check_move map entity_pos dir =
+  let x, y, current_dir = entity_pos in
+  let x, y =
+    if current_dir <> dir then (x, y)
+    else
       match dir with
       | Left -> (x - 1, y)
       | Right -> (x + 1, y)
       | Down -> (x, y + 1)
       | Up -> (x, y - 1)
-    in
-    match get_tile_kind ~x ~y map with
-    | Black | Water -> ()
-    | Grass -> map.player_pos <- (x, y)
-  end
-  else map.player_dir <- dir
+  in
+  match get_tile_kind ~x ~y map with
+  | Black | Water -> Error "invalid terrain"
+  | Grass -> Ok (x, y, dir)

src/network.ml

@@ -3,3 +3,9 @@ let marshal o = Marshal.to_string o [] |> Format.sprintf "%S"
 let unmarshal o =
   let s = Scanf.sscanf o "%S" (fun s -> s) in
   Marshal.from_string s 0
+
+type server_message =
+  | Full_state of State.t
+  | Update_result of (State.action', string) result
+
+type client_message = Action_msg of State.action

src/state.ml

@@ -1,17 +1,33 @@
 type t =
   { map : Map.t
-  ; mutable mana : int
+  ; mana : int
+  ; player_pos : Map.position
   }
 
-let init () = { map = Map.init (); mana = 0 }
+let init () = { map = Map.init (); mana = 0; player_pos = (20, 3, Down) }
 
-type action = Meditate
+type action =
+  | Meditate
+  (* TODO some action do not needs to be checked by server *)
+  | Move of Map.dir
+  | Do_nothing
 
-(* TODO do not send whole state *)
-let handle_action state action =
-  match action with
+(* type for result of action send to the client by the server *)
+type action' =
+  | Add_mana of int
+  | Set_player_position of Map.position
+  | Look_at_the_sky
+
+let check_action state = function
   | Meditate ->
-    if state.mana < 99 then (
-      state.mana <- succ state.mana;
-      Ok state )
-    else Error "maximum mana"
+    if state.mana < 99 then Ok (Add_mana 1) else Error "maximum mana"
+  | Move dir -> (
+    match Map.check_move state.map state.player_pos dir with
+    | Error _e as error -> error
+    | Ok pos -> Ok (Set_player_position pos) )
+  | Do_nothing -> Ok Look_at_the_sky
+
+let perform_action state = function
+  | Add_mana n -> { state with mana = state.mana + n }
+  | Set_player_position player_pos -> { state with player_pos }
+  | Look_at_the_sky -> state

src/ws.ml

@@ -6,23 +6,37 @@ let handle_client request client =
   | None -> Dream.log "User does not exists" |> Lwt.return
   | Some user_id ->
     (* TODO catch marshal failure *)
-    Dream.log " SEND USER ISLAND";
-    (* send user island state *)
     let state =
       match User.get_state user_id with
       | Error _e -> assert false
       | Ok state -> state
     in
-    let* () = Dream.send ~text_or_binary:`Text client (Network.marshal state) in
-    Dream.log " SENDED USER ISLAND";
+    let state_msg = Network.Full_state state in
 
-    let rec loop () =
+    (* send user island state *)
+    let* () =
+      Dream.send ~text_or_binary:`Text client (Network.marshal state_msg)
+    in
+
+    let rec loop state =
       match%lwt Dream.receive client with
       | None -> Dream.close_websocket client
       | Some s ->
-        let action : State.action = Network.unmarshal s in
-        let state_res = State.handle_action state action in
-        let* () = Dream.send client (Network.marshal state_res) in
-        loop ()
+        let (Network.Action_msg action : Network.client_message) =
+          Network.unmarshal s
+        in
+        let res, state =
+          match State.check_action state action with
+          | Error _e as error -> (error, state)
+          | Ok action' ->
+            (* update server state *)
+            let state = State.perform_action state action' in
+            User.set_state user_id state;
+            (Ok action', state)
+        in
+        let* () =
+          Dream.send client (Network.marshal (Network.Update_result res))
+        in
+        loop state
     in
-    loop ()
+    loop state

src/ws_client.ml

@@ -25,17 +25,15 @@ let on_event ws_event log_msg f =
 let to_server_msg ev =
   Format.printf "to_server_msg@.";
   let data = Message.Ev.data (Ev.as_type ev) |> Jstr.to_string in
-  let state_res : (State.t, string) result = Network.unmarshal data in
+  let server_msg : Network.server_message = Network.unmarshal data in
   Format.printf "un-marshaled message from server yay ~ @\n";
-  match state_res with
-  | Error e -> failwith (Format.sprintf "action resulted in error: %s" e)
-  | Ok state -> state
+  server_msg
 
 let on_update_state_message f =
   on_event Message.Ev.message "Websocket reveived message!" (fun ev ->
       f (to_server_msg ev) )
 
-let send msg =
+let send (msg : Network.client_message) =
   Format.printf "send msg on websocket ~~ @\n";
   let s = Jstr.of_string (Network.marshal msg) in
   Websocket.send_string ws s;