Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
dying.hs
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Socket.Table where
import Control.Concurrent hiding ( yield )
import Control.Concurrent.Async
import Control.Concurrent.STM
import qualified Data.Map.Lazy as M
import Database.Persist.Postgresql
import qualified Network.WebSockets as WS
import Data.Text ( Text )
import Database.Persist.Postgresql ( ConnectionString )
import Types
import Control.Lens hiding ( Fold )
import Poker.Types hiding ( LeaveSeat )
import Control.Monad.Except
import Control.Monad.Reader
import System.Random
import Poker.Game.Blinds
import Poker.Game.Privacy
import Poker.Game.Game
import Poker.Types ( Player )
import Poker.ActionValidation
import Data.Maybe
import Data.Either
import Poker.Game.Utils
import Socket.Types
import Socket.Utils
import Poker.Poker
import Database
import Pipes.Aeson
import Pipes hiding ( next )
import Pipes.Core ( push )
import Pipes.Concurrent
import Pipes.Lift
import Pipes.Parse hiding ( decode
, encode
, next
)
import qualified Pipes.Prelude as P
import Prelude
newtype AICount = AICount Int deriving (Show, Eq)
data GameEnv = GameEnv
{ _envConnStr :: ConnectionString
, _envServerState :: TVar ServerState
, _envTableName :: TableName
, _envBotGameOutMailbox :: Input Game
, _envBotGameInMailbox :: Output Game
, _envGameOutMailbox :: Input Game
, _envGameInMailbox:: Output Game
, _envAICount :: AICount
}
makeLenses ''GameEnv
type GamePipe a = Pipe Game Game (ReaderT GameEnv IO) a
-- When a new game state is created then it runs through this pipe.
-- New game states are send to the table's incoming mailbox every time a player acts
-- in a way that follows the game rules. These new game states are then processed
-- in our game pipeline.
setUpTablePipes
:: ConnectionString -> TVar ServerState -> TableName -> Table -> IO (Async ())
setUpTablePipes _envConnStr _envServerState _envTableName Table {..} = do
(_envBotGameInMailbox, _envBotGameOutMailbox) <- spawn $ newest 1
let env = GameEnv
{ _envGameInMailbox = gameInMailbox
, _envGameOutMailbox = gameOutMailbox
, _envAICount = AICount 1
, ..
}
a <-
async
$ forever
$ runEffect
$ runReaderP env
$ gameProducer
>-> gamePipeline
>-> progress
s <-
async
$ forever
$ runEffect
$ runReaderP env
$ fromInput _envBotGameOutMailbox
>-> playBot "Abott"
link a
link s
return a
where gameProducer = fromInput gameOutMailbox
playBot :: Text -> Consumer Game (ReaderT GameEnv IO) ()
playBot name = do
GameEnv {..} <- ask
g@Game {..} <- await
let canAct = isRight $ isPlayerActingOutOfTurn g name
let takeSeatAction = PlayerAction { action = SitDown newPlyr, .. }
liftIO $ print "Can Act"
liftIO $ print "Can Act"
liftIO $ print $ runPlayerAction g takeSeatAction
liftIO $ print "Can bot sit"
liftIO $ print $ isRight $ canSit newPlyr g
liftIO $ print "prints up to here"
liftIO $ print $ canAct
when (isRight $ canSit newPlyr g) $ liftIO $ void $ do
let eitherNewGame = runPlayerAction g takeSeatAction
case eitherNewGame of
Left e -> print e >> return ()
Right newGame -> runEffect $ yield newGame >-> toOutput _envGameInMailbox
liftIO $ print "____we dont ever get to here________-"
when (canAct) $ liftIO $ void $ runBotAction _envConnStr
_envServerState
g
name
where
newPlyr = initPlayer name 2000
takeSeatAction = PlayerAction { action = SitDown newPlyr, .. }
-- this is the pipeline of effects we run everytime a new game state
-- is placed in the tables
-- incoming mailbox for new game states.
gamePipeline :: Pipe Game Game (ReaderT GameEnv IO) ()
gamePipeline = do
broadcast
>-> logGame
>-> updateTable
-- >-> writeGameToDB
>-> nextStagePause
>-> timePlayer
timePlayer :: Pipe Game Game (ReaderT GameEnv IO) ()
timePlayer = do
GameEnv {..} <- ask
g@Game {..} <- await
let currPlyrToAct = (!!) (getGamePlayerNames g) <$> _currentPosToAct
liftIO $ forM_ currPlyrToAct $ runPlayerTimer _envServerState _envTableName g
yield g
where
-- We watch incoming game states. We compare the initial gamestates
-- with the game state when the timer ends.
-- If the state is still the same then we timeout the player to act
-- to force the progression of the game.
runPlayerTimer
:: TVar ServerState -> TableName -> Game -> PlayerName -> IO (Async ())
runPlayerTimer s tableName gameWhenTimerStarts plyrName = async $ do
threadDelay $ 30 * 1000000 -- 30 seconds
mbTable <- atomically $ getTable s tableName
case mbTable of
Nothing -> return ()
Just Table {..} -> do
let gameHasNotProgressed = gameWhenTimerStarts == game
playerStillHasToAct = doesPlayerHaveToAct plyrName game
when (gameHasNotProgressed && playerStillHasToAct)
$ case runPlayerAction game timeoutAction of
Left err -> print err
Right progressedGame ->
runEffect $ yield progressedGame >-> toOutput gameInMailbox
where timeoutAction = PlayerAction { name = plyrName, action = Timeout }
-- Delay between game stages so users don't just see a quick flurry of game states
nextStagePause :: Pipe Game Game (ReaderT GameEnv IO) ()
nextStagePause = do
g <- await
when (canProgressGame g) $ liftIO $ threadDelay $ pauseDuration g
yield g
where
pauseDuration :: Game -> Int
pauseDuration g@Game {..} | _street == PreDeal = 250000
| -- 0.25 second
_street == Showdown = 4 * 1000000
| -- 4 seconds
countPlayersNotAllIn g <= 1 = 4 * 1000000
| otherwise = 1 * 1000000 -- 1 seconds
-- Progresses to the next state which awaits a player action.
--
--- If the next game state is one where no player action is possible
-- then we need to recursively progress the game.
-- These such states are:
--
-- 1. everyone is all in.
-- 1. All but one player has folded or the game.
-- 3. Game is in the Showdown stage.
--
-- After each progression the new game state is sent to the table
-- mailbox. This sends the new game state through the pipeline that
-- the previous game state just went through.
progress :: Consumer Game (ReaderT GameEnv IO) ()
progress = do
GameEnv {..} <- ask
g <- await
liftIO $ print "can progress game in pipe?"
liftIO $ print $ (canProgressGame g)
when (canProgressGame g) (progress' g _envGameInMailbox)
where
progress' game gInMailbox = do
gen <- liftIO getStdGen
liftIO $ setStdGen $ snd $ next gen
liftIO $ print "PIPE PROGRESSING GAME"
let newGame = progressGame gen game
runEffect $ yield newGame >-> toOutput gInMailbox
writeGameToDB :: Pipe Game Game (ReaderT GameEnv IO) ()
writeGameToDB = do
GameEnv {..} <- ask
table <- liftIO $ dbGetTableEntity _envConnStr _envTableName
let (Entity tableKey _) = fromMaybe (notFoundErr _envTableName) table
game <- await
_ <- liftIO $ async $ dbInsertGame _envConnStr tableKey game
yield game
where
notFoundErr name = error $ "Table " <> show name <> " doesn't exist in DB"
-- sends new game states to subscribers
-- At the moment all clients receive updates from every game indiscriminately
-- Without filtering out games that dont concern them.
--
-- -- write MsgOuts for new game states to outgoing mailbox for
-- -- client's who are observing the table
-- -- ensure they only get to see data they are allowed to see
broadcast :: Pipe Game Game (ReaderT GameEnv IO) ()
broadcast = do
GameEnv {..} <- ask
game <- await
ServerState {..} <- liftIO $ readTVarIO _envServerState
let usernames' = M.keys clients -- usernames to broadcast to
liftIO $ runEffect $ yield game >-> toOutput _envBotGameInMailbox
liftIO $ async $ mapM_ (informSubscribers _envTableName game) clients
yield game
where
-- write MsgOuts for new game states to outgoing mailbox for
-- client's who are observing the table
-- ensure they only get to see data they are allowed to see
informSubscribers :: TableName -> Game -> Client -> IO ()
informSubscribers n g Client {..} = do
let filteredGame = excludeOtherPlayerCards clientUsername g
runEffect $ yield (NewGameState n filteredGame) >-> toOutput outgoingMailbox
return ()
logGame :: Pipe Game Game (ReaderT GameEnv IO) ()
logGame = do
game <- await
yield game
-- Lookups up a table with the given name and writes the new game state
-- to the gameIn mailbox for propagation to observers.
--
-- If table with tableName is not found in the serverState lobby
-- then we just return () and do nothing.
toGameInMailbox :: TVar ServerState -> TableName -> Game -> IO ()
toGameInMailbox s name game = do
table' <- atomically $ getTable s name
forM_ table' send
where send Table {..} = runEffect $ yield game >-> toOutput gameInMailbox
-- Get a combined outgoing mailbox for a group of clients who are observing a table
--
-- Here we monoidally combined so we then have one mailbox
-- we use to broadcast new game states to which will be sent out to each client's
-- socket connection under the hood
combineOutMailboxes :: [Client] -> Consumer MsgOut IO ()
combineOutMailboxes clients = toOutput $ foldMap outgoingMailbox clients
getTable :: TVar ServerState -> TableName -> STM (Maybe Table)
getTable s tableName = do
ServerState {..} <- readTVar s
return $ M.lookup tableName $ unLobby lobby
updateTable :: Pipe Game Game (ReaderT GameEnv IO) ()
updateTable = do
GameEnv {..} <- ask
game <- await
liftIO $ atomically $ updateTable' _envServerState _envTableName game
yield game
updateTable' :: TVar ServerState -> TableName -> Game -> STM ()
updateTable' serverStateTVar tableName newGame = do
ServerState {..} <- readTVar serverStateTVar
case M.lookup tableName $ unLobby lobby of
Nothing -> throwSTM $ TableDoesNotExistInLobby tableName
Just table@Table {..} -> do
let updatedLobby = updateTableGame tableName newGame lobby
swapTVar serverStateTVar ServerState { lobby = updatedLobby, .. }
return ()
updateTableAndGetMailbox
:: TVar ServerState -> TableName -> Game -> STM (Maybe (Output Game))
updateTableAndGetMailbox serverStateTVar tableName newGame = do
ServerState {..} <- readTVar serverStateTVar
case M.lookup tableName $ unLobby lobby of
Nothing -> throwSTM $ TableDoesNotExistInLobby tableName
Just table@Table {..} -> do
let updatedLobby = updateTableGame tableName newGame lobby
swapTVar serverStateTVar ServerState { lobby = updatedLobby, .. }
return $ Just gameInMailbox
updateTableGame :: TableName -> Game -> Lobby -> Lobby
updateTableGame tableName newGame (Lobby lobby) = Lobby
$ M.adjust updateTable tableName lobby
where updateTable Table {..} = Table { game = newGame, .. }
runBotAction
:: ConnectionString -> TVar ServerState -> Game -> PlayerName -> IO ()
runBotAction dbConn serverStateTVar g pName = do
maybeAction <- getValidBotAction g pName
-- print g
print ("Random action from " <> show pName <> " is " <> show maybeAction)
case maybeAction of
Nothing -> return ()
Just a -> do
let eitherNewGame = runPlayerAction g a
case eitherNewGame of
Left gameErr -> print (show $ GameErr gameErr) >> return ()
Right g -> do
void $ liftIO $ async $ toGameInMailbox serverStateTVar tableName g
-- liftIO $ atomically $ updateTable' serverStateTVar tableName g
where
tableName = "Black"
chipsToSit = 2000
-- sitDownBot :: ConnectionString -> Player -> Game -> IO ()
-- sitDownBot dbConn player@Player {..} g gameInMailbox = do
-- print "BOT Sitting!!!"
-- print "BOT Sitting!!!"
-- print "BOT Sitting!!!"
-- print "BOT Sitting!!!"
-- let gameMove = SitDown player
-- let eitherNewGame = runPlayerAction game takeSeatAction
-- case eitherNewGame of
-- Left gameErr -> print $ GameErr gameErr
-- Right g -> do
-- dbDepositChipsIntoPlay dbConn _playerName chipsToSit
-- void $ liftIO $ async $ toGameInMailbox serverStateTVar tableName g
-- -- liftIO $ atomically $ updateTable' serverStateTVar tableName g
-- where
-- chipsToSit = 2000
-- tableName = "Black"
-- takeSeatAction = PlayerAction { name = _playerName, action = SitDown player }
getValidBotAction :: Game -> PlayerName -> IO (Maybe PlayerAction)
getValidBotAction g@Game {..} name
| length _players < 2 = return Nothing
| _street == PreDeal = return $ case blindRequiredByPlayer g name of
Small -> Just $ PlayerAction { action = PostBlind Small, .. }
Big -> Just $ PlayerAction { action = PostBlind Big, .. }
NoBlind -> Nothing
| otherwise = do
betAmount' <- randomRIO (lowerBetBound, chipCount)
let possibleActions = (actions _street betAmount')
let actionsValidated = validateAction g name <$> possibleActions
let pNameActionPairs = zip possibleActions actionsValidated
print pNameActionPairs
let validActions = (<$>) fst $ filter (isRight . snd) pNameActionPairs
print validActions
when (null validActions) panic
randIx <- randomRIO (0, length validActions - 1)
return $ Just $ PlayerAction { action = validActions !! randIx, .. }
where
actions :: Street -> Int -> [Action]
actions st chips | st == PreDeal = [PostBlind Big, PostBlind Small]
| otherwise = [Check, Call, Fold, Bet chips, Raise chips]
lowerBetBound = if (_maxBet > 0) then 2 * _maxBet else _bigBlind
chipCount = maybe 0 (^. chips) (getGamePlayer g name)
panic = do
print $ "UHOH no valid actions for " <> show name
print g
error $ "UHOH no valid actions"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment