Add websocket server

This commit is contained in:
Correl Roush 2017-08-23 19:24:00 -04:00
parent be02a1fa12
commit 7fb216a351
15 changed files with 392 additions and 63 deletions

View file

@ -8,10 +8,12 @@
], ],
"exposed-modules": [], "exposed-modules": [],
"dependencies": { "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/list-extra": "6.1.0 <= v < 7.0.0",
"elm-community/maybe-extra": "4.0.0 <= v < 5.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/core": "5.0.0 <= v < 6.0.0",
"elm-lang/html": "2.0.0 <= v < 3.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": "9.1.0 <= v < 10.0.0",
"rtfeldman/elm-css-helpers": "2.1.0 <= v < 3.0.0" "rtfeldman/elm-css-helpers": "2.1.0 <= v < 3.0.0"
}, },

93
priv/src/Client.elm Normal file
View file

@ -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 ]
]

View file

@ -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))

16
priv/src/Client/Game.elm Normal file
View file

@ -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

18
priv/src/Client/Hand.elm Normal file
View file

@ -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
]

View file

@ -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
]

View file

@ -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
]

View file

@ -1,6 +1,6 @@
module Riichi exposing (..) module Riichi exposing (..)
import Hand import Client
import Html exposing (..) import Html exposing (..)
import Html.Attributes exposing (..) import Html.Attributes exposing (..)
import Html.Events exposing (onClick) import Html.Events exposing (onClick)
@ -14,32 +14,19 @@ import Stylesheets as S
type alias Model = type alias Model =
{ tileset : S.Tileset { tileset : S.Tileset
, hand : Hand.Model , client : Client.Model
} }
type Msg type Msg
= SetTileset S.Tileset = SetTileset S.Tileset
| ClientMsg Client.Msg
init : ( Model, Cmd Msg ) init : ( Model, Cmd Msg )
init = init =
( { tileset = S.White ( { 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 , Cmd.none
) )
@ -53,6 +40,15 @@ update msg model =
, Cmd.none , 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 : Program Never Model Msg
main = main =
@ -60,10 +56,15 @@ main =
{ init = init { init = init
, update = update , update = update
, view = view , 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 -> Html Msg
view model = view model =
div [ class [ S.Tileset model.tileset ] ] div [ class [ S.Tileset model.tileset ] ]
@ -73,7 +74,7 @@ view model =
, radio "tileset" "White" (SetTileset S.White) (model.tileset == S.White) , radio "tileset" "White" (SetTileset S.White) (model.tileset == S.White)
, radio "tileset" "Black" (SetTileset S.Black) (model.tileset == S.Black) , radio "tileset" "Black" (SetTileset S.Black) (model.tileset == S.Black)
] ]
, Hand.view model.hand , Client.view model.client
] ]

View file

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

View file

@ -5,6 +5,7 @@
-export([new/0, -export([new/0,
new/1, new/1,
new/2, new/2,
send/2,
discards/1, discards/1,
draw/2]). draw/2]).
@ -12,11 +13,14 @@ new() ->
new("Computer"). new("Computer").
new(Name) -> 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) -> discards(#player{discards = Discards} = Player) ->
[{discard, Tile, Player#player{hand = Hand, discards = [Tile|Discards]}} [{discard, Tile, Player#player{hand = Hand, discards = [Tile|Discards]}}

56
src/player_websocket.erl Normal file
View file

@ -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).

View file

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

View file

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

View file

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

91
src/server_websocket.erl Normal file
View file

@ -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)}.