Add websocket server

priv/elm-package.json

@@ -8,10 +8,12 @@
     ],
     "exposed-modules": [],
     "dependencies": {
+        "elm-community/json-extra": "2.3.0 <= v < 3.0.0",
         "elm-community/list-extra": "6.1.0 <= v < 7.0.0",
         "elm-community/maybe-extra": "4.0.0 <= v < 5.0.0",
         "elm-lang/core": "5.0.0 <= v < 6.0.0",
         "elm-lang/html": "2.0.0 <= v < 3.0.0",
+        "elm-lang/websocket": "1.0.2 <= v < 2.0.0",
         "rtfeldman/elm-css": "9.1.0 <= v < 10.0.0",
         "rtfeldman/elm-css-helpers": "2.1.0 <= v < 3.0.0"
     },

priv/src/Client.elm

@@ -0,0 +1,93 @@
+module Client exposing (..)
+
+import Debug
+import Client.Decode
+import Client.Game exposing (Game)
+import Html exposing (..)
+import Json.Decode exposing (decodeString)
+import String
+import WebSocket
+
+
+type alias Model =
+    { game : Maybe Game
+    , log : List String
+    }
+
+
+type Msg
+    = Receive String
+    | Send String
+    | Log String
+    | NewState Game
+
+
+init : Model
+init =
+    { game = Nothing
+    , log = []
+    }
+
+
+update : Msg -> Model -> ( Model, Cmd Msg )
+update msg model =
+    case msg of
+        Receive m ->
+            socketMsg m
+                |> Maybe.map (\msg -> update msg model)
+                |> Maybe.withDefault ( model, Cmd.none )
+
+        Log m ->
+            ( { model | log = m :: model.log }
+            , Cmd.none
+            )
+
+        NewState game ->
+            ( { model | game = Just (Debug.log "game" game) }
+            , Cmd.none
+            )
+
+        _ ->
+            ( model, Cmd.none )
+
+
+socketMsg : String -> Maybe Msg
+socketMsg message =
+    let
+        splitMsg =
+            case String.split ":" message of
+                msgType :: rest ->
+                    Just ( msgType, String.join ":" rest )
+
+                _ ->
+                    Nothing
+
+        toMsg ( msgType, rest ) =
+            case msgType of
+                "log" ->
+                    Just (Log rest)
+
+                "new_state" ->
+                    decodeString Client.Decode.game rest
+                        |> Result.toMaybe
+                        |> Maybe.map NewState
+
+                _ ->
+                    Nothing
+    in
+        splitMsg
+            |> Maybe.andThen toMsg
+
+
+subscriptions : Model -> Sub Msg
+subscriptions model =
+    WebSocket.listen "ws://localhost:8080/websocket" Receive
+
+
+view : Model -> Html msg
+view model =
+    div []
+        [ Maybe.map Client.Game.view model.game
+            |> Maybe.withDefault (div [] [])
+        , pre [] [ text <| String.join "\n" model.log ]
+        ]

priv/src/Client/Decode.elm

@@ -0,0 +1,49 @@
+module Client.Decode exposing (..)
+
+import Client.Hand exposing (Hand)
+import Client.Game exposing (Game)
+import Client.Player exposing (Player)
+import Json.Decode exposing (..)
+import Json.Decode.Extra exposing (fromResult)
+import Tile exposing (Tile)
+
+
+tile : Decoder Tile
+tile =
+    let
+        combine a b =
+            a ++ " " ++ b
+
+        stringOrInt =
+            oneOf
+                [ string
+                , int |> map toString
+                ]
+    in
+        map2 combine
+            (field "value" stringOrInt)
+            (field "suit" string)
+            |> andThen
+                (Tile.fromString
+                    >> (Result.fromMaybe "invalid tile")
+                    >> fromResult
+                )
+
+
+hand : Decoder Hand
+hand =
+    map Hand
+        (field "tiles" (list tile))
+
+
+player : Decoder Player
+player =
+    map2 Player
+        (field "name" string)
+        (field "hand" hand)
+
+
+game : Decoder Game
+game =
+    map Game
+        (field "players" (list player))

priv/src/Client/Game.elm

@@ -0,0 +1,16 @@
+module Client.Game exposing (..)
+
+import Client.Player exposing (Player)
+import Html exposing (..)
+
+
+type alias Game =
+    { players : List Player }
+
+
+view : Game -> Html msg
+view game =
+    div [] <|
+        List.map
+            Client.Player.view
+            game.players

priv/src/Client/Hand.elm

@@ -0,0 +1,18 @@
+module Client.Hand exposing (..)
+
+import Html exposing (Html, div, text)
+import Html.Attributes exposing (class)
+import Tile exposing (Tile)
+
+
+type alias Hand =
+    { tiles : List Tile
+    }
+
+
+view : Hand -> Html a
+view model =
+    div [ class "hand" ]
+        [ div [ class "tiles open" ] <|
+            List.map Tile.view model.tiles
+        ]

priv/src/Client/Player.elm

@@ -0,0 +1,18 @@
+module Client.Player exposing (..)
+
+import Client.Hand exposing (Hand)
+import Html exposing (..)
+
+
+type alias Player =
+    { name : String
+    , hand : Hand
+    }
+
+
+view : Player -> Html msg
+view player =
+    fieldset []
+        [ legend [] [ text ("Player: " ++ player.name) ]
+        , Client.Hand.view player.hand
+        ]

priv/src/Hand.elm

@@ -1,33 +0,0 @@
-module Hand exposing (..)
-
-import Html exposing (Html, div, text)
-import Html.Attributes exposing (class)
-import Maybe.Extra
-import Tile exposing (Tile)
-
-
-type alias JSON =
-    { tiles : List String
-    }
-
-
-type alias Model =
-    { tiles : List Tile
-    }
-
-
-fromJSON : JSON -> Model
-fromJSON j =
-    { tiles =
-        j.tiles
-            |> List.map Tile.fromString
-            |> Maybe.Extra.values
-    }
-
-
-view : Model -> Html a
-view model =
-    div [ class "hand" ]
-        [ div [ class "tiles open" ] <|
-            List.map Tile.view model.tiles
-        ]

priv/src/Riichi.elm

@@ -1,6 +1,6 @@
 module Riichi exposing (..)
 
-import Hand
+import Client
 import Html exposing (..)
 import Html.Attributes exposing (..)
 import Html.Events exposing (onClick)
@@ -14,32 +14,19 @@ import Stylesheets as S
 
 type alias Model =
     { tileset : S.Tileset
-    , hand : Hand.Model
+    , client : Client.Model
     }
 
 
 type Msg
     = SetTileset S.Tileset
+    | ClientMsg Client.Msg
 
 
 init : ( Model, Cmd Msg )
 init =
     ( { tileset = S.White
-      , hand =
+      , client = Client.init
-            Hand.fromJSON
-                { tiles =
-                    [ "4 pin"
-                    , "5 pin"
-                    , "6 pin"
-                    , "4 sou"
-                    , "5 sou"
-                    , "6 sou"
-                    , "4 man"
-                    , "5 man"
-                    , "6 man"
-                    , "red dragon"
-                    ]
-                }
       }
     , Cmd.none
     )
@@ -53,6 +40,15 @@ update msg model =
             , Cmd.none
             )
 
+        ClientMsg m ->
+            let
+                ( client, effects ) =
+                    Client.update m model.client
+            in
+                ( { model | client = client }
+                , Cmd.map ClientMsg effects
+                )
+
 
 main : Program Never Model Msg
 main =
@@ -60,10 +56,15 @@ main =
         { init = init
         , update = update
         , view = view
-        , subscriptions = \_ -> Sub.none
+        , subscriptions = subscriptions
         }
 
 
+subscriptions : Model -> Sub Msg
+subscriptions model =
+    Sub.batch [ Sub.map ClientMsg <| Client.subscriptions model.client ]
+
+
 view : Model -> Html Msg
 view model =
     div [ class [ S.Tileset model.tileset ] ]
@@ -73,7 +74,7 @@ view model =
             , radio "tileset" "White" (SetTileset S.White) (model.tileset == S.White)
             , radio "tileset" "Black" (SetTileset S.Black) (model.tileset == S.Black)
             ]
-        , Hand.view model.hand
+        , Client.view model.client
         ]
 
 

rebar.config

@@ -1,5 +1,13 @@
 %% -*- mode: erlang -*-
 
+{plugins, [rebar3_auto]}.
+
+{deps, [cowboy,
+        lager,
+        jsx]}.
+
+{erl_opts, [{parse_transform, lager_transform}]}.
+
 {pre_hooks,
  [{"(linux|darwin|solaris)",  compile,"make  elm"},
   {"(freebsd|netbsd|openbsd)",compile,"gmake elm"},

src/player.erl

@@ -5,6 +5,7 @@
 -export([new/0,
          new/1,
          new/2,
+         send/2,
          discards/1,
          draw/2]).
 
@@ -12,11 +13,14 @@ new() ->
     new("Computer").
 
 new(Name) ->
-    new(Name, player_dummy).
+    {ok, Pid} = player_dummy:start_link(Name),
+    new(Name, Pid).
 
-new(Name, Type) ->
+new(Name, Pid) ->
-    {ok, PID} = Type:start_link(Name),
+    #player{name = Name, pid = Pid}.
-    #player{name = Name, pid = PID}.
+
+send(#player{pid = Pid}, Message) ->
+    gen_server:cast(Pid, Message).
 
 discards(#player{discards = Discards} = Player) ->
     [{discard, Tile, Player#player{hand = Hand, discards = [Tile|Discards]}}

src/player_websocket.erl

@@ -0,0 +1,56 @@
+-module(player_websocket).
+-behaviour(gen_server).
+
+-export([start_link/1]).
+-export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2,
+         code_change/3]).
+
+-record(state, {socket, game, seat}).
+
+start_link(Socket) ->
+    gen_server:start_link(?MODULE, [Socket], []).
+
+init([Socket]) ->
+    Socket ! <<"oh hello!">>,
+    {ok, #state{socket=Socket}}.
+
+handle_call({choose, Actions}, _From, State) ->
+    %% [Action|_] = sort_actions(Actions),
+    %% {reply, Action, State};
+    State#state.socket ! {choose, Actions},
+    {noreply, State};
+
+handle_call(get_name, _From, State) ->
+    {reply, io_lib:format("~p", [State#state.socket]), State};
+
+handle_call(_Msg, _From, State) ->
+    {noreply, State}.
+
+handle_cast(Msg, State) ->
+    State#state.socket! Msg,
+    {noreply, State}.
+
+handle_info(Msg, State) ->
+    State#state.socket ! Msg,
+    {noreply, State}.
+
+terminate(_Reason, _State) ->
+    ok.
+
+code_change(_OldVsn, State, _Extra) ->
+    {ok, State}.
+
+sort_actions(Actions) ->
+    Order = fun({game_action, A, _, _}, {game_action, B, _, _}) ->
+                    Weighted = [ron, tsumo, kan, pon, chi],
+                    Weights = lists:zip(Weighted, lists:reverse(lists:seq(1, length(Weighted)))),
+                    VA = proplists:get_value(A, Weights, 0),
+                    VB = proplists:get_value(B, Weights, 0),
+                    case VA == VB of
+                        true ->
+                            A >= B;
+                        _ ->
+                            VA >= VB
+                    end
+            end,
+    lists:sort(Order, Actions).

src/riichi.app.src

@@ -6,7 +6,9 @@
   {applications, [
                   kernel,
                   stdlib,
-                  cowboy
+                  lager,
+                  cowboy,
+                  jsx
                  ]},
   {modules, []},
   {mod, { riichi_app, []}},

src/riichi_app.erl

@@ -14,7 +14,8 @@ start(_StartType, _StartArgs) ->
                  [{'_', [{"/", cowboy_static, {priv_file, riichi, "index.html"}},
                          {"/js/[...]", cowboy_static, {priv_dir, riichi, "js"}},
                          {"/css/[...]", cowboy_static, {priv_dir, riichi, "css"}},
-                         {"/images/[...]", cowboy_static, {priv_dir, riichi, "images"}}
+                         {"/images/[...]", cowboy_static, {priv_dir, riichi, "images"}},
+                         {"/websocket", server_websocket, []}
                         ]}
                  ]),
     {ok, _} = cowboy:start_http(

src/server_game.erl

@@ -2,7 +2,7 @@
 -behaviour(gen_fsm).
 
 -export([start_link/0]).
--export([waiting/3,
+-export([waiting/2,
          playing/2,
          turn/2]).
 -export([init/1, handle_event/3, handle_sync_event/4, handle_info/3, terminate/3, code_change/4]).
@@ -17,16 +17,19 @@ start_link() ->
 init([]) ->
     {ok, waiting, #state{}}.
 
-waiting({add_player, Player}, _From, State) ->
+waiting({add_player, Player}, State) ->
     error_logger:info_report({adding_player, [{player, Player}]}),
     Players = [Player|State#state.players],
+    [player:send(P, {joined, Player}) || P <- Players],
     case length(Players) of
         4 ->
             Game = game:new(Players),
             error_logger:info_report({starting_game, []}),
+            [player:send(P, {log ,<<"starting game">>}) || P <- Players],
             gen_fsm:send_event(self(), game_tree:build(Game)),
-            {reply, ok, playing, Game};
+            {next_state, playing, Game};
-        _ -> {reply, ok, waiting, State#state{players=Players}}
+        _ ->
+            {next_state, waiting, State#state{players=Players}}
     end.
 
 playing({game_tree, Game, Branches} = Tree, State) ->
@@ -40,7 +43,7 @@ playing({game_tree, Game, Branches} = Tree, State) ->
                                                      [] ->
                                                          [];
                                                      _ ->
-                                                         [gen_server:call(Player#player.pid, {choose, PlayerActions})]
+                                                         [gen_server:call(Player#player.pid, {choose, PlayerActions}, infinity)]
                                                  end
                                          end,
                                          [east, south, west, north])),

src/server_websocket.erl

@@ -0,0 +1,91 @@
+-module(server_websocket).
+-behaviour(cowboy_http_handler).
+-behaviour(cowboy_websocket_handler).
+
+-include("../include/riichi.hrl").
+
+-export([init/3, handle/2, terminate/3]).
+-export([
+         websocket_init/3, websocket_handle/3,
+         websocket_info/3, websocket_terminate/3
+        ]).
+
+-record(state, {game, player}).
+
+init({tcp, http}, _Req, _Opts) ->
+    {upgrade, protocol, cowboy_websocket}.
+
+handle(_Req, State) ->
+    {ok, Response} = cowboy_http_req:reply(404, [{'Content-Type', <<"text/html">>}]),
+    {ok, Response, State}.
+
+websocket_init(_TransportName, Req, _Opts) ->
+    lager:info("init websocket"),
+    {ok, Game} = server_game:start_link(),
+    {ok, Pid} = player_websocket:start_link(self()),
+    Player = player:new("Websocket", Pid),
+    gen_fsm:send_event(Game, {add_player, Player}),
+    [gen_fsm:send_event(Game,{add_player, player:new()})
+     || _N <- lists:seq(1, 3)],
+    {ok, Req, #state{game=Game,player=Player}}.
+
+websocket_handle({text, Msg}, Req, State) ->
+    lager:info("Got Data: ~p", [Msg]),
+    {reply, {text, << "responding to ", Msg/binary >>}, Req, State, hibernate };
+
+
+websocket_handle(_Any, Req, State) ->
+    {reply, {text, << "whut?">>}, Req, State, hibernate }.
+
+websocket_info({timeout, _Ref, Msg}, Req, State) ->
+    {reply, {text, Msg}, Req, State};
+
+websocket_info(Info, Req, State) ->
+    lager:info("websocket info: ~p", [Info]),
+    case encode(Info) of
+        {ok, Msg} ->
+            {reply, {text, Msg}, Req, State};
+        {error, _Reason} ->
+            lager:error("Unhandled message: ~p", [Info]),
+            {ok, Req, State, hibernate}
+    end.
+
+websocket_terminate(_Reason, _Req, _State) ->
+    ok.
+
+terminate(_Reason, _Req, _State) ->
+    ok.
+
+encode({log, Msg}) ->
+    {ok, io_lib:format("log: ~s", [Msg])};
+encode({new_state, Game}) ->
+    {ok, ["new_state: ", jsx:encode(encode_game(Game))]};
+encode(_) ->
+    {error, invalid_message}.
+
+encode_game(Game) ->
+    #{round => Game#game.round,
+      turn => Game#game.turn,
+      phase => Game#game.phase,
+      wall => length(Game#game.wall),
+      dora => lists:map(fun encode_tile/1, Game#game.dora),
+      players => lists:map(fun encode_player/1, Game#game.players)}.
+
+encode_tile(Tile) ->
+    #{suit => Tile#tile.suit,
+      value => Tile#tile.value,
+      from => Tile#tile.from}.
+
+encode_player(Player) ->
+    #{name => list_to_binary(Player#player.name),
+      seat => Player#player.seat,
+      hand => encode_hand(Player#player.hand),
+      discards => lists:map(fun encode_tile/1, Player#player.discards)}.
+
+encode_hand(Hand) ->
+    #{tiles => lists:map(fun encode_tile/1, Hand#hand.tiles),
+      melds => lists:map(fun encode_meld/1, Hand#hand.melds)}.
+
+encode_meld(Meld) ->
+    #{type => Meld#meld.type,
+      tiles => lists:map(fun encode_tile/1, Meld#meld.tiles)}.