diff options
| -rw-r--r-- | black.txt | 1 | ||||
| -rw-r--r-- | client/src/Client.elm | 39 | ||||
| -rw-r--r-- | client/src/Messages.elm | 35 | ||||
| -rw-r--r-- | server/cafp.cabal | 1 | ||||
| -rw-r--r-- | server/lib/Cafp/Game.hs | 14 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/GenerateElmTypes.hs | 1 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/Server.hs | 15 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 12 |
8 files changed, 85 insertions, 33 deletions
@@ -1,3 +1,4 @@ +# These are the old cards I copied. A crypto conference is never complete without \BLANK. A recent laboratory study shows that undergrads have 50\% less sex after being exposed to \BLANK. A romantic, candlelit dinner would be incomplete without \BLANK. diff --git a/client/src/Client.elm b/client/src/Client.elm index 41871e9..5c6d167 100644 --- a/client/src/Client.elm +++ b/client/src/Client.elm @@ -1,9 +1,10 @@ port module Client exposing (main) +import Array exposing (Array) import Browser -import Html exposing (Html) import Html.Attributes import Html.Events +import Html exposing (Html) import Json.Decode import Json.Encode import Messages exposing (GameView) @@ -20,13 +21,16 @@ type Msg | ChangeMyName String | SubmitMyName +type alias Cards = {black : Array String, white : Array String} + type Model = Error String | Connecting { roomId : String } | Game - { view : GameView + { cards : Cards + , view : GameView , changeMyName : String } @@ -70,21 +74,21 @@ view model = case model of ] ++ (case game.view.blackCard of Nothing -> [] - Just c -> [blackCard c]) ++ - (List.map whiteCard game.view.hand) + Just c -> [blackCard game.cards c]) ++ + (List.map (whiteCard game.cards) game.view.hand) -blackCard : Messages.BlackCard -> Html a -blackCard (Messages.BlackCard string) = +blackCard : Cards -> Messages.BlackCard -> Html a +blackCard cards (Messages.BlackCard idx) = let blank = Html.span [Html.Attributes.class "blank"] [] in Html.div [Html.Attributes.class "card", Html.Attributes.class "black"] <| - List.intersperse blank <| - List.map Html.text <| - String.split "\\BLANK" string + List.intersperse blank <| List.map Html.text <| + String.split "\\BLANK" <| Maybe.withDefault "" <| + Array.get idx cards.black -whiteCard : Messages.WhiteCard -> Html a -whiteCard (Messages.WhiteCard string) = Html.div +whiteCard : Cards -> Messages.WhiteCard -> Html a +whiteCard cards (Messages.WhiteCard idx) = Html.div [Html.Attributes.class "card", Html.Attributes.class "white"] - [Html.text string] + [Html.text <| Maybe.withDefault "" <| Array.get idx cards.white] subscriptions : Model -> Sub Msg subscriptions model = webSocketIn WebSocketIn @@ -107,11 +111,20 @@ update msg model = case msg of Game game -> (Game {game | view = gameView}, Cmd.none) _ -> ( Game - { view = gameView + { cards = {black = Array.empty, white = Array.empty} + , view = gameView , changeMyName = gameView.myName } , Cmd.none ) + Ok (Messages.SyncCards cards) -> + let arr = + { black = Array.fromList cards.black + , white = Array.fromList cards.white + } in + case model of + Game game -> (Game {game | cards = arr}, Cmd.none) + _ -> (model, Cmd.none) ChangeMyName name -> case model of Game game -> (Game {game | changeMyName = name}, Cmd.none) diff --git a/client/src/Messages.elm b/client/src/Messages.elm index d2c2716..15a0d1c 100644 --- a/client/src/Messages.elm +++ b/client/src/Messages.elm @@ -9,30 +9,50 @@ import Set exposing (Set) type BlackCard = - BlackCard String + BlackCard Int jsonDecBlackCard : Json.Decode.Decoder ( BlackCard ) jsonDecBlackCard = - Json.Decode.lazy (\_ -> Json.Decode.map BlackCard (Json.Decode.string)) + Json.Decode.lazy (\_ -> Json.Decode.map BlackCard (Json.Decode.int)) jsonEncBlackCard : BlackCard -> Value jsonEncBlackCard (BlackCard v1) = - Json.Encode.string v1 + Json.Encode.int v1 type WhiteCard = - WhiteCard String + WhiteCard Int jsonDecWhiteCard : Json.Decode.Decoder ( WhiteCard ) jsonDecWhiteCard = - Json.Decode.lazy (\_ -> Json.Decode.map WhiteCard (Json.Decode.string)) + Json.Decode.lazy (\_ -> Json.Decode.map WhiteCard (Json.Decode.int)) jsonEncWhiteCard : WhiteCard -> Value jsonEncWhiteCard (WhiteCard v1) = - Json.Encode.string v1 + Json.Encode.int v1 + + + +type alias Cards = + { black: (List String) + , white: (List String) + } + +jsonDecCards : Json.Decode.Decoder ( Cards ) +jsonDecCards = + Json.Decode.succeed (\pblack pwhite -> {black = pblack, white = pwhite}) + |> required "black" (Json.Decode.list (Json.Decode.string)) + |> required "white" (Json.Decode.list (Json.Decode.string)) + +jsonEncCards : Cards -> Value +jsonEncCards val = + Json.Encode.object + [ ("black", (Json.Encode.list Json.Encode.string) val.black) + , ("white", (Json.Encode.list Json.Encode.string) val.white) + ] @@ -64,6 +84,7 @@ jsonEncGameView val = type ServerMessage = Welcome Int + | SyncCards Cards | SyncGameView GameView | Bye @@ -71,6 +92,7 @@ jsonDecServerMessage : Json.Decode.Decoder ( ServerMessage ) jsonDecServerMessage = let jsonDecDictServerMessage = Dict.fromList [ ("Welcome", Json.Decode.lazy (\_ -> Json.Decode.map Welcome (Json.Decode.int))) + , ("SyncCards", Json.Decode.lazy (\_ -> Json.Decode.map SyncCards (jsonDecCards))) , ("SyncGameView", Json.Decode.lazy (\_ -> Json.Decode.map SyncGameView (jsonDecGameView))) , ("Bye", Json.Decode.lazy (\_ -> Json.Decode.succeed Bye)) ] @@ -80,6 +102,7 @@ jsonEncServerMessage : ServerMessage -> Value jsonEncServerMessage val = let keyval v = case v of Welcome v1 -> ("Welcome", encodeValue (Json.Encode.int v1)) + SyncCards v1 -> ("SyncCards", encodeValue (jsonEncCards v1)) SyncGameView v1 -> ("SyncGameView", encodeValue (jsonEncGameView v1)) Bye -> ("Bye", encodeValue (Json.Encode.list identity [])) in encodeSumObjectWithSingleField keyval val diff --git a/server/cafp.cabal b/server/cafp.cabal index 0dc068b..9bb2250 100644 --- a/server/cafp.cabal +++ b/server/cafp.cabal @@ -31,6 +31,7 @@ Library stm >= 2.5 && < 2.6, text >= 1.2 && < 1.3, unordered-containers >= 0.2 && < 0.3, + vector >= 0.12 && < 0.13, wai >= 3.2 && < 3.3, wai-websockets >= 3.0 && < 3.1, warp >= 3.3 && < 3.4, diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index ad33368..740eac5 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -5,6 +5,7 @@ module Cafp.Game ( PlayerId , Cards (..) , Game (..) + , gameCards, gamePlayers, gameNextPlayerId , newGame , joinGame @@ -16,7 +17,8 @@ module Cafp.Game ) where import Cafp.Messages -import Control.Lens (at, ix, over, (%~), (&), (.~), (^.), (^?)) +import Control.Lens (at, ix, over, to, (%~), (&), (.~), (^.), + (^?)) import Control.Lens.TH (makeLenses) import qualified Data.HashMap.Strict as HMS import Data.Maybe (fromMaybe) @@ -25,18 +27,12 @@ import qualified Data.Text as T type PlayerId = Int -data Cards = Cards - { _cardsBlack :: [BlackCard] - , _cardsWhite :: [WhiteCard] - } deriving (Show) - data Game = Game { _gameCards :: !Cards , _gamePlayers :: !(HMS.HashMap Int Text) , _gameNextPlayerId :: !Int } deriving (Show) -makeLenses ''Cards makeLenses ''Game newGame :: Cards -> Game @@ -65,6 +61,6 @@ gameViewForPlayer self game = GameView { gameViewOpponents = opponents , gameViewMyName = name - , gameViewBlackCard = game ^? gameCards . cardsBlack . ix 0 - , gameViewHand = take 10 $ game ^. gameCards . cardsWhite + , gameViewBlackCard = Just $ BlackCard 0 + , gameViewHand = [WhiteCard x | x <- [0 .. 9]] } diff --git a/server/lib/Cafp/Main/GenerateElmTypes.hs b/server/lib/Cafp/Main/GenerateElmTypes.hs index 51376a5..7900b1c 100644 --- a/server/lib/Cafp/Main/GenerateElmTypes.hs +++ b/server/lib/Cafp/Main/GenerateElmTypes.hs @@ -12,6 +12,7 @@ main :: IO () main = putStrLn $ makeElmModule "Messages" [ DefineElm (Proxy :: Proxy BlackCard) , DefineElm (Proxy :: Proxy WhiteCard) + , DefineElm (Proxy :: Proxy Cards) , DefineElm (Proxy :: Proxy GameView) , DefineElm (Proxy :: Proxy ServerMessage) , DefineElm (Proxy :: Proxy ClientMessage) diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs index 3edf039..e6e353f 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -9,6 +9,7 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.STM (STM, TVar, atomically) import qualified Control.Concurrent.STM as STM import Control.Exception (bracket) +import Control.Lens ((^.)) import Control.Monad (forever, when) import qualified Data.Aeson as Aeson import qualified Data.ByteString as B @@ -20,6 +21,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL +import qualified Data.Vector as V import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WebSockets as WaiWs @@ -46,8 +48,11 @@ data Server = Server readCards :: IO Cards readCards = Cards - <$> fmap (map BlackCard . T.lines) (T.readFile "assets/black.txt") - <*> fmap (map WhiteCard . T.lines) (T.readFile "assets/white.txt") + <$> fmap parseCards (T.readFile "assets/black.txt") + <*> fmap parseCards (T.readFile "assets/white.txt") + where + parseCards = + filter (not . T.isPrefixOf "#") . filter (not . T.null) . T.lines newServer :: IO Server newServer = Server <$> readCards <*> atomically (STM.newTVar HMS.empty) @@ -117,13 +122,17 @@ wsApp server pc = case routePendingConnection pc of Just roomId -> do room <- atomically $ getOrCreateRoom server roomId conn <- WS.acceptRequest pc + let sink = WS.sendTextData conn WS.withPingThread conn 30 (pure ()) $ bracket - (atomically $ joinRoom room (WS.sendTextData conn)) + (atomically $ joinRoom room sink) (\playerId -> do atomically $ leaveRoom room playerId syncRoom room) (\playerId -> do syncRoom room + cards <- fmap (^. gameCards) . atomically . STM.readTVar $ + roomGame room + sink . Aeson.encode $ SyncCards cards loop conn roomId playerId) where loop conn roomId playerId = forever $ do diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs index 542189f..219efb4 100644 --- a/server/lib/Cafp/Messages.hs +++ b/server/lib/Cafp/Messages.hs @@ -2,6 +2,7 @@ module Cafp.Messages ( BlackCard (..) , WhiteCard (..) + , Cards (..) , GameView (..) , ServerMessage (..) , ClientMessage (..) @@ -10,9 +11,14 @@ module Cafp.Messages import Data.Text (Text) import Elm.Derive -data BlackCard = BlackCard Text deriving (Show) +data BlackCard = BlackCard Int deriving (Show) -data WhiteCard = WhiteCard Text deriving (Show) +data WhiteCard = WhiteCard Int deriving (Show) + +data Cards = Cards + { cardsBlack :: [Text] + , cardsWhite :: [Text] + } deriving (Show) data GameView = GameView { gameViewOpponents :: [Text] @@ -23,6 +29,7 @@ data GameView = GameView data ServerMessage = Welcome Int + | SyncCards Cards | SyncGameView GameView | Bye deriving (Show) @@ -33,6 +40,7 @@ data ClientMessage deriveBoth defaultOptions ''BlackCard deriveBoth defaultOptions ''WhiteCard +deriveBoth (defaultOptionsDropLower 5) ''Cards deriveBoth (defaultOptionsDropLower 8) ''GameView deriveBoth defaultOptions ''ServerMessage deriveBoth defaultOptions ''ClientMessage |