aboutsummaryrefslogtreecommitdiff
path: root/server/lib/Cafp/Main
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-07-30 21:48:22 +0200
committerJasper Van der Jeugt2020-07-30 21:48:22 +0200
commitab1267a757bcc997f05cc9babe2d1fb9bb681ce4 (patch)
tree2d044f0a704f76c5b2adaa7a506bce406410ba48 /server/lib/Cafp/Main
parent68588db76baaf8f2f17dd9b7f3649b09e102ea85 (diff)
Sync cards only once
Diffstat (limited to 'server/lib/Cafp/Main')
-rw-r--r--server/lib/Cafp/Main/GenerateElmTypes.hs1
-rw-r--r--server/lib/Cafp/Main/Server.hs15
2 files changed, 13 insertions, 3 deletions
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