aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--black.txt1
-rw-r--r--client/src/Client.elm39
-rw-r--r--client/src/Messages.elm35
-rw-r--r--server/cafp.cabal1
-rw-r--r--server/lib/Cafp/Game.hs14
-rw-r--r--server/lib/Cafp/Main/GenerateElmTypes.hs1
-rw-r--r--server/lib/Cafp/Main/Server.hs15
-rw-r--r--server/lib/Cafp/Messages.hs12
8 files changed, 85 insertions, 33 deletions
diff --git a/black.txt b/black.txt
index e7383a5..0c886bd 100644
--- a/black.txt
+++ b/black.txt
@@ -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