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": [],
"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"
},

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 (..)
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 =
Hand.fromJSON
{ tiles =
[ "4 pin"
, "5 pin"
, "6 pin"
, "4 sou"
, "5 sou"
, "6 sou"
, "4 man"
, "5 man"
, "6 man"
, "red dragon"
]
}
, client = Client.init
}
, 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
]

View file

@ -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"},

View file

@ -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) ->
{ok, PID} = Type:start_link(Name),
#player{name = Name, pid = PID}.
new(Name, 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]}}

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, [
kernel,
stdlib,
cowboy
lager,
cowboy,
jsx
]},
{modules, []},
{mod, { riichi_app, []}},

View file

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

View file

@ -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};
_ -> {reply, ok, waiting, State#state{players=Players}}
{next_state, playing, Game};
_ ->
{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])),

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