Repository: therewillbecode/haskell-poker
Branch: master
Commit: 29f3717b3b8e
Files: 160
Total size: 443.2 KB
Directory structure:
gitextract_6a575bnu/
├── README.md
├── client/
│ ├── .babelrc
│ ├── .dockerignore
│ ├── .editorconfig
│ ├── .eslintignore
│ ├── .eslintrc
│ ├── .gitattributes
│ ├── .gitignore
│ ├── .prettierrc
│ ├── .travis.yml
│ ├── Dockerfile
│ ├── LICENSE.md
│ ├── README.md
│ ├── app/
│ │ ├── actions/
│ │ │ ├── auth.js
│ │ │ ├── games.js
│ │ │ ├── lobby.js
│ │ │ ├── profile.js
│ │ │ ├── socket.js
│ │ │ ├── tests/
│ │ │ │ └── auth.test.js
│ │ │ └── types.js
│ │ ├── app.js
│ │ ├── components/
│ │ │ ├── ActionPanel.js
│ │ │ ├── App.js
│ │ │ ├── Board.js
│ │ │ ├── Card.js
│ │ │ ├── Footer.js
│ │ │ ├── Game.js
│ │ │ ├── Home.js
│ │ │ ├── Lobby.js
│ │ │ ├── NavBar.js
│ │ │ ├── NotFoundPage.js
│ │ │ ├── Profile.js
│ │ │ ├── Seat.js
│ │ │ ├── SignInForm.js
│ │ │ ├── SignUpForm.js
│ │ │ └── Signout.js
│ │ ├── configureStore.js
│ │ ├── containers/
│ │ │ ├── AppContainer.js
│ │ │ ├── GameContainer.js
│ │ │ ├── HomeContainer.js
│ │ │ ├── LobbyContainer.js
│ │ │ ├── NavBarContainer.js
│ │ │ ├── ProfileContainer.js
│ │ │ ├── SignInFormContainer.js
│ │ │ └── SignUpFormContainer.js
│ │ ├── index.html
│ │ ├── middleware/
│ │ │ └── socket.js
│ │ ├── reducers/
│ │ │ ├── auth.js
│ │ │ ├── games.js
│ │ │ ├── lobby.js
│ │ │ ├── profile.js
│ │ │ ├── rootReducer.js
│ │ │ ├── socket.js
│ │ │ └── tests/
│ │ │ └── auth.test.js
│ │ ├── reducers.js
│ │ ├── selectors/
│ │ │ ├── auth.js
│ │ │ ├── games.js
│ │ │ ├── lobby.js
│ │ │ ├── profile.js
│ │ │ ├── route.js
│ │ │ ├── socket.js
│ │ │ └── tests/
│ │ │ └── games.test.js
│ │ ├── styles/
│ │ │ ├── _common.scss
│ │ │ ├── common/
│ │ │ │ ├── _colours.scss
│ │ │ │ ├── _mixins.scss
│ │ │ │ ├── _typography.scss
│ │ │ │ └── _variables.scss
│ │ │ ├── components/
│ │ │ │ ├── _buttons.scss
│ │ │ │ ├── _footer.scss
│ │ │ │ ├── _forms.scss
│ │ │ │ ├── _game.scss
│ │ │ │ ├── _lobby.scss
│ │ │ │ ├── _navbar.scss
│ │ │ │ └── game/
│ │ │ │ ├── _actionPanel.scss
│ │ │ │ ├── _boardCards.scss
│ │ │ │ ├── _cards.scss
│ │ │ │ ├── _seat.scss
│ │ │ │ ├── _slider.scss
│ │ │ │ └── _table.scss
│ │ │ ├── layout/
│ │ │ │ └── _app.scss
│ │ │ └── main.scss
│ │ └── utils/
│ │ └── request.js
│ ├── config/
│ │ ├── jest-mocks/
│ │ │ ├── cssModule.js
│ │ │ └── image.js
│ │ ├── jest.config.js
│ │ ├── test-setup.js
│ │ ├── webpack.base.babel.js
│ │ ├── webpack.dev.babel.js
│ │ └── webpack.prod.babel.js
│ ├── jest.config.js
│ ├── netlify.toml
│ ├── package.json
│ ├── server/
│ │ ├── index.js
│ │ ├── middlewares/
│ │ │ ├── addDevMiddlewares.js
│ │ │ ├── addProdMiddlewares.js
│ │ │ └── frontendMiddleware.js
│ │ └── util/
│ │ ├── argv.js
│ │ ├── logger.js
│ │ └── port.js
│ ├── shell.nix
│ └── static/
│ └── fonts/
│ └── GothamPro/
│ └── GothamHTF-BookCondensed.otf
├── docker-compose.yml
└── server/
├── .dev.env
├── .dockerignore
├── .gitignore
├── .projectile
├── ChangeLog.md
├── Dockerfile
├── README.md
├── Setup.hs
├── UNLICENSE.txt
├── app/
│ └── Main.hs
├── bootstrap.sh
├── deploy-server.sh
├── deploy.sh
├── docs/
│ ├── lobbyAPI.md
│ ├── socket.md
│ └── userAPI.md
├── package.yaml
├── ping.sh
├── provision.sh
├── server.service
├── shell.nix
├── src/
│ ├── API.hs
│ ├── Bots.hs
│ ├── Database.hs
│ ├── Env.hs
│ ├── Poker/
│ │ ├── ActionValidation.hs
│ │ ├── Game/
│ │ │ ├── Actions.hs
│ │ │ ├── Blinds.hs
│ │ │ ├── Game.hs
│ │ │ ├── Hands.hs
│ │ │ ├── Privacy.hs
│ │ │ └── Utils.hs
│ │ ├── Poker.hs
│ │ └── Types.hs
│ ├── Schema.hs
│ ├── Socket/
│ │ ├── Auth.hs
│ │ ├── Clients.hs
│ │ ├── Lobby.hs
│ │ ├── Msg.hs
│ │ ├── Setup.hs
│ │ ├── Subscriptions.hs
│ │ ├── Table.hs
│ │ ├── Types.hs
│ │ ├── Utils.hs
│ │ └── Workers.hs
│ ├── Socket.hs
│ ├── Types.hs
│ └── Users.hs
├── stack.yaml
└── test/
├── Poker/
│ ├── ActionSpec.hs
│ ├── ActionValidationSpec.hs
│ ├── BlindSpec.hs
│ ├── GameSpec.hs
│ ├── Generators.hs
│ ├── HandSpec.hs
│ └── UtilsSpec.hs
├── PokerSpec.hs
└── Spec.hs
================================================
FILE CONTENTS
================================================
================================================
FILE: README.md
================================================
# Poker Maison
## A poker app crafted with Haskell and React
Supports games across multiple tables in realtime.
Player moves are timed in order to ensure that games keep running if players disconnect.
The UI and backend are all implemented in less than seven thousand lines of code.

[](http://unlicense.org/)

## How to run in docker
Skip this section if you would rather avoid docker.
### Docker Prerequisites
In order to use Docker have the following installed.
- [Docker](https://docs.docker.com/compose/install/) (17.12.0+)
- [Docker Compose](https://docs.docker.com/v17.09/engine/installation/)
- [Docker Machine](https://docs.docker.com/machine/install-machine/)
Firstly start Docker Machine
```bash
docker-machine start
```
Then set the correct variables in your terminal so you can connect to Docker Machine
```bash
eval $(docker-machine env)
```
Now build the images. This will take a while.
```
docker-compose up
```
Now go navigate to http://192.168.99.100:3000 in your browser and the app should be running.
The above ip address is the one for your docker-machine VM if you are on the default settings. By default docker-machine doesn't serve localhost but instead uses 192.168.99.100 as the host.
You can simulate multiple players in the same game on on your machine if you navigate to the above url in a few different browser tabs. Eac time you open up a new tab just remember to log out after you have signed in as the browser will cache the access_token for the last logged in user for each new tab as URL is the same.
## Common Docker Problems
### Docker has the wrong TLS setting
If you get the error below then Docker Compose is not using the correct TLS version.
```
Building web
ERROR: SSL error: HTTPSConnectionPool(host='192.168.99.100', port=2376): Max retries exceeded with url: /v1.30/build?q=False&pull=False&t=server_web&nocache=False&forcerm=False&rm=True (Caused by SSLError(SSLError(1, u'[SSL: TLSV1_ALERT_PROTOCOL_VERSION] tlsv1 alert protocol version (_ssl.c:727)'),))
```
You can fix this by setting the following environment variable with the correct TLS version.
```bash
export COMPOSE_TLS_VERSION=TLSv1_2
```
### Container runs out of memory
If the server docker container runs out of memory whilst building. Whis would look like this.
```
-- While building package Cabal-2.4.1.0 using:
/root/.stack/setup-exe-cache/x86_64-linux/Cabal-simple_mPHDZzAJ_2.4.0.1_ghc-8.6.5 --builddir=.stack-work/dist/x86_64-linux/Cabal-2.4.0.1 build --ghc-options ""
Process exited with code: ExitFailure (-9) (THIS MAY INDICATE OUT OF MEMORY)
```
Then set increase the memory available to the VM you are using for docker-machine.
Assuming your VM is named "default", run:
```bash
docker-machine stop default
VBoxManage modifyvm default --memory 4096
docker-machine start default
```
### Slow builds
If you want to speed up builds then replace `n` in the command below
with the number of cores your machine has and run the command.
The command below assumes that "default" is the name of the VM Docker Machine is using.
```bash
docker-machine stop default
VBoxManage modifyvm default --cpus n
docker-machine start default
```
# Building locally from scratch.
The following steps are based on an Ubuntu distribution.
## Back End
Firstly make sure you have ghc and stack installed in order to compile the back end written in Haskell.
If you need to install the Haskell platform then run
```bash
curl -sSL https://get.haskellstack.org/ | sh
```
Secondly install libpq (c bindings to postgres)
```bash
sudo apt-get install libpq-dev
```
Next install redis.
```bash
sudo apt-get install redis
```
Navigate to the server/ directory.
```bash
cd server
```
Compile the back end poker server.
```bash
stack build
```
## Now we need to set some config.
Ensure postgresql 10 is installed and running.
Set the env var so that the server has the postgresql connection string.
Of course you will need to change the db connection parameters below to match your local database.
```bash
export dbConnStr='host=0.0.0.0 port=5432 user=postgres dbname=pokerdbtest password=postgres
```
Set env variable with the secret key for generating auth tokens.
Note that this secret must be 32 characters long or it won't work.
```bash
export secret="changeme077cf4e7441c32d2d0a86b4c"
```
Lastly ensure redis-server is running in the background on default port
```bash
redis-server
```
Now run the server locally. The default user API port is 8000 and websocket port is 5000.
```bash
stack run
```
## Front End
Install node version 10.16.3 and then install yarn globally
```bash
npm i -g yarn@1.17.3
```
Install a required system dependency for node-sass .
```bash
sudo apt-get install libpng-dev
```
Navigate to the client/ directory with
```bash
cd client
```
Then just run.
```bash
yarn start
```
Now you are ready to play poker!
### Simulating a multiplayer game locally
You may want to play against yourself when you are developing locally so just
run the clients on two separate ports.
In your first terminal run
```
PORT=8001 yarn start
```
Then open another terminal and run
```
PORT=8002 yarn start
```
Now just open two tabs in your browser navigating to
```
localhost:8001
```
and
```
localhost:8002
```
## Running Tests
To run the test suite on the backend which has over a hundred tests
```bash
cd server && stack test
```
## Contributions Welcome
Have a look at the issues if you want some starting ideas on how to get involved.
Feel free to open any issues with potential enhancements or bugs you have found.
## License
This is free and unencumbered software released into the public domain.
For more information, please refer to the `UNLICENSE` file or [unlicense.org](http://unlicense.org).
================================================
FILE: client/.babelrc
================================================
{
"presets": [
[
"env",
{
"modules": false
}
],
"react",
"stage-0"
],
"env": {
"production": {
"only": ["app"],
"plugins": [
"transform-react-remove-prop-types",
"transform-react-constant-elements",
"transform-react-inline-elements"
]
},
"test": {
"plugins": ["transform-es2015-modules-commonjs", "dynamic-import-node"]
}
}
}
================================================
FILE: client/.dockerignore
================================================
node_modules
================================================
FILE: client/.editorconfig
================================================
# editorconfig.org
root = true
[*]
charset = utf-8
end_of_line = lf
insert_final_newline = true
indent_style = space
indent_size = 2
trim_trailing_whitespace = true
[*.md]
trim_trailing_whitespace = false
================================================
FILE: client/.eslintignore
================================================
/build/**
/coverage/**
/docs/**
/jsdoc/**
/templates/**
/tests/bench/**
/tests/fixtures/**
/tests/performance/**
/tmp/**
/lib/util/unicode/is-combining-character.js
/sass/
/node/modules
test.js
!.eslintrc.js
.gitignore
================================================
FILE: client/.eslintrc
================================================
{
"parser": "babel-eslint",
"extends": [
"airbnb",
"plugin:react/recommended",
"prettier/react",
"prettier"
],
"env": {
"browser": true,
"node": true,
"jest": true,
"es6": true
},
"plugins": [
"react",
"jsx-a11y",
"prettier"
],
"parserOptions": {
"ecmaVersion": 6,
"sourceType": "module",
"ecmaFeatures": {
"jsx": true
}
},
"rules": {
"no-param-reassign": "off",
"arrow-parens": "off",
"function-paren-newline": "off",
"comma-dangle": [
"error",
"only-multiline"
],
"import/no-extraneous-dependencies": 0,
"import/prefer-default-export": 0,
"indent": [
2,
2,
{
"SwitchCase": 1
}
],
"max-len": 0,
"no-console": 1,
"react/forbid-prop-types": 0,
"react/jsx-curly-brace-presence": "off",
"react/jsx-first-prop-new-line": [
2,
"multiline"
],
"react/jsx-filename-extension": 0,
"react/self-closing-comp": 0,
"jsx-a11y/anchor-is-valid": 0
},
"settings": {
"import/resolver": {
"webpack": {
"config": "./config/webpack.prod.babel.js"
}
}
}
}
================================================
FILE: client/.gitattributes
================================================
# From https://github.com/Danimoth/gitattributes/blob/master/Web.gitattributes
# Handle line endings automatically for files detected as text
# and leave all files detected as binary untouched.
* text=auto
#
# The above will handle all files NOT found below
#
#
## These files are text and should be normalized (Convert crlf => lf)
#
# source code
*.php text
*.css text
*.sass text
*.scss text
*.less text
*.styl text
*.js text eol=lf
*.coffee text
*.json text
*.htm text
*.html text
*.xml text
*.svg text
*.txt text
*.ini text
*.inc text
*.pl text
*.rb text
*.py text
*.scm text
*.sql text
*.sh text
*.bat text
# templates
*.ejs text
*.hbt text
*.jade text
*.haml text
*.hbs text
*.dot text
*.tmpl text
*.phtml text
# server config
.htaccess text
.nginx.conf text
# git config
.gitattributes text
.gitignore text
.gitconfig text
# code analysis config
.jshintrc text
.jscsrc text
.jshintignore text
.csslintrc text
# misc config
*.yaml text
*.yml text
.editorconfig text
# build config
*.npmignore text
*.bowerrc text
# Heroku
Procfile text
.slugignore text
# Documentation
*.md text
LICENSE text
AUTHORS text
#
## These files are binary and should be left untouched
#
# (binary is a macro for -text -diff)
*.png binary
*.jpg binary
*.jpeg binary
*.gif binary
*.ico binary
*.mov binary
*.mp4 binary
*.mp3 binary
*.flv binary
*.fla binary
*.swf binary
*.gz binary
*.zip binary
*.7z binary
*.ttf binary
*.eot binary
*.woff binary
*.pyc binary
*.pdf binary
================================================
FILE: client/.gitignore
================================================
# Don't check auto-generated stuff into git
coverage
build
node_modules
stats.json
# Cruft
.DS_Store
npm-debug.log
.idea
# Logs
yarn-error.log
================================================
FILE: client/.prettierrc
================================================
{
"singleQuote": true,
"semi": false
}
================================================
FILE: client/.travis.yml
================================================
language: node_js
os: osx
node_js:
- 8
- 6
script:
- npm run test
- npm run build
notifications:
email:
on_failure: change
cache:
yarn: true
directories:
- node_modules
================================================
FILE: client/Dockerfile
================================================
# base image
FROM node:10.16.3-alpine
RUN apk add --no-cache \
autoconf \
automake \
bash \
g++ \
libc6-compat \
libjpeg-turbo-dev \
libpng-dev \
make \
nasm
WORKDIR /app
RUN npm install yarn@1.17.3 -g
# install and cache app dependencies
COPY package.json .
RUN yarn
COPY . .
CMD yarn run start:docker
================================================
FILE: client/LICENSE.md
================================================
The MIT License (MIT)
Copyright (c) 2018 Dinesh Pandiyan
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
================================================
FILE: client/README.md
================================================
A minimal, beginner friendly React-Redux boilerplate with all the industry best practices
## Why? [](http://www.ted.com/talks/simon_sinek_how_great_leaders_inspire_action)
The whole React community knows and will unanimously agree that [react-boilerplate](https://github.com/react-boilerplate/react-boilerplate) is the ultimate starter template for kickstarting a React project. It's setup with all the industry best practices and standards. But it also has a lot more than what you just need to start a react-redux app. It took me quite some time to get my head around what was happening in the codebase and it's clearly not for starters. They quote this right in their readme,
> Please note that this boilerplate is **production-ready and not meant for beginners**! If you're just starting out with react or redux, please refer to https://github.com/petehunt/react-howto instead. If you want a solid, battle-tested base to build your next product upon and have some experience with react, this is the perfect start for you.
So it involves a lot of additional learning curve to get started with [react-boilerplate](https://github.com/react-boilerplate/react-boilerplate). That's why I forked it, stripped it down and made this _leaner, **beginner friendly**_ boilerplate without all the additional complexity.
## Features
This boilerplate features all the latest tools and practices in the industry.
- _React.js_ - **React 16**✨, React Router 5
- _Redux.js_ - Redux saga, Redux immutable and Reselect
- _Babel_ - ES6, ESNext, Airbnb and React/Recommended config
- _Webpack_ - **Webpack 4**✨, Hot Reloading, Code Splitting, Optimized Prod Build and more
- _Test_ - Jest with Enzyme
- _Lint_ - ESlint
- _Styles_ - SCSS Styling
Here are a few highlights to look out for in this boilerplate
Instant feedback
Enjoy the best DX (Developer eXperience) and code your app at the speed of thought! Your saved changes to the CSS and JS are reflected instantaneously without refreshing the page. Preserve application state even when you update something in the underlying code!
Next generation JavaScript
Use template strings, object destructuring, arrow functions, JSX syntax and more, today.
Component Specific Styles
Separate styles for each component. Style in the good old scss way but still keep it abstracted for each component.
Industry-standard routing
It's natural to want to add pages (e.g. `/about`) to your application, and routing makes this possible.
Predictable state management
Unidirectional data flow allows for change logging and time travel debugging.
SEO
We support SEO (document head tags management) for search engines that support indexing of JavaScript content. (eg. Google)
But wait... there's more!
- *The best test setup:* Automatically guarantee code quality and non-breaking
changes. (Seen a react app with 99% test coverage before?)
- *The fastest fonts:* Say goodbye to vacant text.
- *Stay fast*: Profile your app's performance from the comfort of your command
line!
- *Catch problems:* TravisCI setup included by default, so your
tests get run automatically on each code push.
## Quick start
1. Clone this repo using `git clone https://github.com/flexdinesh/react-redux-boilerplate.git`
2. Move to the appropriate directory: `cd react-redux-boilerplate`.
3. Run `yarn` or `npm install` to install dependencies.
4. Run `npm start` to see the example app at `http://localhost:3000`.
Now you're ready build your beautiful React Application!
## Info
These are the things I stripped out from [react-boilerplate](https://github.com/react-boilerplate/react-boilerplate) - _github project rules, ngrok tunneling, shjs, service worker, webpack dll plugin, i18n, styled-components, code generators and a few more._
## License
MIT license, Copyright (c) 2018 Dinesh Pandiyan.
================================================
FILE: client/app/actions/auth.js
================================================
import axios from 'axios'
import * as types from './types'
import { checkStatus } from '../utils/request'
/* Action Creators for Socket API authentication */
// Redux Socket Middleware intercepts this action and handles connection logic
export const connectSocket = token => ({
type: types.CONNECT_SOCKET,
token
})
export const disconnectSocket = () => ({ type: types.DISCONNECT_SOCKET })
export const logoutUser = history => dispatch => {
localStorage.removeItem('token')
dispatch(logout())
dispatch(disconnectSocket())
history.push('/')
}
console.log('env var', process.env)
const AUTH_API_URL =
process.env.NODE_ENV === 'docker'
? 'http://192.168.99.100:8000'
: process.env.NODE_ENV === 'production'
? 'https://tenpoker.co.uk'
: 'http://localhost:8000'
export const authRequested = () => ({ type: types.AUTH_REQUESTED })
export const authSuccess = username => ({ type: types.AUTHENTICATED, username })
export const authError = error => ({ type: types.AUTHENTICATION_ERROR, error })
export const logout = () => ({ type: types.UNAUTHENTICATED })
export function login(username, password, history) {
return async dispatch => {
dispatch(authRequested())
axios
.post(
`${AUTH_API_URL}/login`,
{
loginUsername: username,
loginPassword: password
},
{
headers: {
'Access-Control-Allow-Origin': '*'
}
}
)
.then(({ data }) => {
const { access_token } = data
dispatch(authSuccess(username))
dispatch(connectSocket(access_token))
localStorage.setItem('token', JSON.stringify({ ...data, username }))
history.push('/profile')
})
.catch(err => dispatch(authError(err)))
}
}
export function register(username, email, password, history) {
return async dispatch => {
dispatch(authRequested())
axios
.post(`${AUTH_API_URL}/register`, {
newUsername: username,
newUserEmail: email,
newUserPassword: password
})
.then(({ data }) => {
const { access_token } = data
dispatch(authSuccess(username))
dispatch(connectSocket(access_token))
localStorage.setItem('token', JSON.stringify({ ...data, username }))
history.push('/profile')
})
.catch(err => dispatch(authError(err)))
}
}
================================================
FILE: client/app/actions/games.js
================================================
import * as types from './types'
export const newGameState = (tableName, gameState) => ({
type: types.NEW_GAME_STATE,
tableName,
gameState
})
export const postBigBlind = tableName => ({
type: types.POST_BIG_BLIND,
data: {
tag: 'GameMsgIn',
contents: {
tag: 'GameMove',
contents: [tableName, { tag: 'PostBlind', contents: 'Big' }]
}
}
})
export const postSmallBlind = tableName => ({
type: types.POST_SMALL_BLIND,
data: {
tag: 'GameMsgIn',
contents: {
tag: 'GameMove',
contents: [tableName, { tag: 'PostBlind', contents: 'Small' }]
}
}
})
export const bet = (tableName, amount) => ({
type: types.BET,
data: {
tag: 'GameMsgIn',
contents: {
tag: 'GameMove',
contents: [tableName, { tag: 'Bet', contents: Number(amount) }]
}
}
})
export const raise = (tableName, amount) => ({
type: types.RAISE,
data: {
tag: 'GameMsgIn',
contents: {
tag: 'GameMove',
contents: [tableName, { tag: 'Raise', contents: Number(amount) }]
}
}
})
export const call = tableName => ({
type: types.CALL,
data: {
tag: 'GameMsgIn',
contents: { tag: 'GameMove', contents: [tableName, { tag: 'Call' }] }
}
})
export const check = tableName => ({
type: types.CHECK,
data: {
tag: 'GameMsgIn',
contents: { tag: 'GameMove', contents: [tableName, { tag: 'Check' }] }
}
})
export const fold = tableName => ({
type: types.FOLD,
data: {
tag: 'GameMsgIn',
contents: { tag: 'GameMove', contents: [tableName, { tag: 'Fold' }] }
}
})
export const leaveSeat = tableName => ({
type: types.LEAVE_SEAT,
data: {
tag: 'GameMsgIn',
contents: {
tag: 'LeaveSeat',
contents: tableName
}
}
})
export const sitIn = tableName => ({
type: types.SIT_IN,
data: { tag: 'GameMove', contents: [tableName, { tag: 'SitIn' }] }
})
================================================
FILE: client/app/actions/lobby.js
================================================
/*
The data value of the action forms the websocket msg payload.
*/
import * as types from './types'
export const getLobby = () => ({
type: types.GET_LOBBY,
data: { tag: 'GetTables' }
})
export const newLobby = lobby => ({ type: types.NEW_LOBBY, lobby })
// should be moved as this is game action
export const takeSeat = (tableName, chips) => ({
type: types.TAKE_SEAT,
data: {
tag: 'GameMsgIn',
contents: {
tag: 'TakeSeat',
contents: [tableName, Number(chips)]
}
}
})
export const subscribeToTable = tableName => ({
type: types.SUBSCRIBE_TO_TABLE,
data: { tag: 'SubscribeToTable', contents: tableName }
})
================================================
FILE: client/app/actions/profile.js
================================================
import axios from 'axios'
import * as types from './types'
/* Action Creators for User API authentication */
const AUTH_API_URL = 'https://tenpoker.co.uk'
//process.env.NODE_ENV === 'production' ? 'https://tenpoker.co.uk' : 'http://localhost:8000'
export const getProfileRequest = () => ({ type: types.GET_PROFILE_REQUEST })
export const getProfileSuccess = profile => ({
type: types.GET_PROFILE_SUCCESS,
profile
})
export const getProfileErr = error => ({ type: types.GET_PROFILE_ERR, error })
export const getProfile = username => {
return dispatch => {
const token = localStorage.getItem('token')
if (token) {
try {
const { access_token } = JSON.parse(token)
dispatch(getProfileRequest())
console.log('access token', access_token)
axios
.get(`${AUTH_API_URL}/profile`, {
headers: {
Authorization: access_token,
'Content-Type': 'application/json'
}
})
.then(({ data }) => {
const profile = {
chipsInPlay: data.proChipsInPlay,
availableChips: data.proAvailableChips,
userCreatedAt: data.proUserCreatedAt,
username: data.proUsername,
email: data.proEmail
}
dispatch(getProfileSuccess(profile))
})
.catch(err => dispatch(getProfileErr(err)))
} catch (e) {
console.log(e)
dispatch(getProfileErr(e))
}
} else {
dispatch(getProfileErr('No JWT token for profile request'))
}
}
}
================================================
FILE: client/app/actions/socket.js
================================================
import * as types from './types'
export const socketConnErr = err => ({ type: types.SOCKET_CONN_ERR, err })
export const socketConnected = socket => ({ type: types.SOCKET_CONNECTED, socket })
export const socketAuthSuccess = () => ({ type: types.SOCKET_AUTH_SUCCESS })
export const socketAuthErr = err => ({ type: types.SOCKET_AUTH_ERR, err })
export const socketReconnecting = () => ({ type: "SOCKET_RECONNECTING" })
export const socketReconnectFail = () => ({ type: "SOCKET_RECONNECT_FAIL" })
================================================
FILE: client/app/actions/tests/auth.test.js
================================================
/* eslint-disable */
import configureMockStore from "redux-mock-store";
import thunk from "redux-thunk";
import axios from "axios";
import { authRequested, authError, authSuccess, login, logout, register } from "../auth";
import * as types from "../types";
const localStorageMock = {
getItem: jest.fn(),
setItem: jest.fn(),
clear: jest.fn()
};
global.localStorage = localStorageMock;
const jestMock = response => jest
.fn()
.mockImplementation(
() =>
new Promise(
(resolve, reject) =>
response.status !== 200 ? reject(response) : resolve(response)
)
);
const stubAxios = response => {
axios.get = jestMock(response)
axios.post = jestMock(response)
};
describe("auth actions", () => {
describe("action creators", () => {
describe("authRequested", () => {
it("should return correct action an authSuccess action for received asset", () => {
expect(authRequested()).toEqual({ type: types.AUTH_REQUESTED })
});
})
describe("authSuccess", () => {
it("should return correct action an authSuccess action for received asset", () => {
const username = 'Argo'
expect(authSuccess(username)).toEqual({ type: types.AUTHENTICATED, username })
});
})
describe("authError", () => {
it("should return correct action an authSuccess action for received asset", () => {
const error = '404'
expect(authError(error)).toEqual({ type: types.AUTHENTICATION_ERROR, error })
});
})
describe("logout", () => {
it("should return correct action an authSuccess action for received asset", () => {
expect(logout()).toEqual({ type: types.UNAUTHENTICATED })
});
})
})
describe("thunk actions", () => {
let mockStore;
let historyMock = { push: jest.fn() } // mocks react router history
describe("signIn", () => {
beforeEach(() => {
const middlewares = [thunk];
mockStore = configureMockStore(middlewares);
});
afterEach(() => {
axios.get.mockReset();
historyMock.push.mockReset()
localStorage.clear()
});
afterAll(() => {
axios.get.mockRestore();
});
const username = 'Argo'
const email = 'email@email.com'
const password = 'password'
it("should dispatch correct actions when authentication succeeds", () => {
const store = mockStore({});
const expectedActions = [
{ type: types.AUTH_REQUESTED },
{ type: types.AUTHENTICATED }
];
stubAxios({ status: 200, data: { token: 'JWT' } });
return store.dispatch(login({ email, password }, historyMock)).then(() => {
expect(store.getActions()).toEqual(expectedActions);
});
});
it("should dispatch correction actions when error occurs while fetching user profile", () => {
const store = mockStore({});
const error = {
"response": { "data": "Unauthorized" }, "status": 401
}
const expectedActions = [
{ type: types.AUTH_REQUESTED },
{ type: types.AUTHENTICATION_ERROR, error }
];
stubAxios({ status: 401, response: { data: "Unauthorized" } });
return store.dispatch(login({ email, password }, historyMock)).then(() => {
expect(store.getActions()).toEqual(expectedActions);
});
});
it("should redirect to correct route on auth success", () => {
const store = mockStore({});
const expectedRoute = '/lobby'
stubAxios({ status: 200, data: { token: 'JWT' } });
return store.dispatch(login({ email, password }, historyMock)).then(() => {
expect(historyMock.push).toBeCalledWith(expectedRoute)
});
});
it("should store JWT token in localStorage on auth success", () => {
const store = mockStore({});
const token = 'JWT'
stubAxios({ status: 200, data: { token } });
return store.dispatch(login({ email, password }, historyMock)).then(() => {
expect(localStorage.setItem).toBeCalledWith('token', token)
});
});
});
});
});
================================================
FILE: client/app/actions/types.js
================================================
/* Actions prefixed with /server denote actions which trigger the sending of a websocket msg to server*/
/* User API Types */
export const AUTH_REQUESTED = 'AUTH_REQUESTED'
export const AUTHENTICATED = 'AUTHENTICATED'
export const UNAUTHENTICATED = 'UNAUTHENTICATED'
export const AUTHENTICATION_ERROR = 'AUTHENTICATION_ERROR'
/* Retrieve User Profile */
export const GET_PROFILE_REQUEST = 'GET_PROFILE_REQUEST'
export const GET_PROFILE_SUCCESS = 'GET_PROFILE_SUCCESS'
export const GET_PROFILE_ERR = 'GET_PROFILE_ERR'
/* Websocket Action Types */
export const CONNECT_SOCKET = 'CONNECT_SOCKET'
export const SOCKET_CONNECTED = 'SOCKET_CONNECTED'
export const DISCONNECT_SOCKET = 'DISCONNECT_SOCKET'
export const SOCKET_AUTH_SUCCESS = 'SOCKET_AUTH_SUCCESS'
export const SOCKET_AUTH_ERR = 'SOCKET_AUTH_ERR'
export const SOCKET_CONN_ERR = 'SOCKET_CONN_ERR'
/* Lobby Action Types */
export const GET_LOBBY = 'server/GET_LOBBY'
export const NEW_LOBBY = 'NEW_LOBBY'
export const TAKE_SEAT = 'server/TAKE_SEAT'
export const SUBSCRIBE_TO_TABLE = 'server/SUBSCRIBE_TO_TABLE'
/* Game Action Types */
export const NEW_GAME_STATE = 'NEW_GAME_STATE'
export const SUCCESSFULLY_SAT_DOWN = 'SUCCESSFULLY_SAT_DOWN'
export const POST_BIG_BLIND = 'server/POST_BIG_BLIND'
export const POST_SMALL_BLIND = 'server/POST_SMALL_BLIND'
export const BET = 'server/BET'
export const RAISE = 'server/RAISE'
export const CHECK = 'server/CHECK'
export const FOLD = 'server/FOLD'
export const CALL = 'server/CALL'
export const SIT_IN = 'server/SIT_IN'
export const LEAVE_SEAT = 'server/LEAVE_SEAT'
================================================
FILE: client/app/app.js
================================================
/**
* app.js
*
* This is the entry file for the application, only setup and boilerplate
* code.
*/
// Needed for redux-saga es6 generator support
import 'babel-polyfill'
// Import all the third party stuff
import React from 'react'
import ReactDOM from 'react-dom'
import { Provider } from 'react-redux'
import { ConnectedRouter } from 'react-router-redux'
import createHistory from 'history/createBrowserHistory'
import 'sanitize.css/sanitize.css'
import AppContainer from 'containers/AppContainer'
import { authSuccess } from './actions/auth'
import 'styles/main.scss'
import configureStore from './configureStore'
// Create redux store with history
const initialState = {}
const history = createHistory()
const store = configureStore(initialState, history)
const MOUNT_NODE = document.getElementById('app')
const render = () => {
ReactDOM.render(
,
MOUNT_NODE
)
}
if (module.hot) {
// Hot reloadable React components and translation json files
// modules.hot.accept does not accept dynamic dependencies,
// have to be constants at compile-time
module.hot.accept(['containers/AppContainer'], () => {
ReactDOM.unmountComponentAtNode(MOUNT_NODE)
render()
})
}
// If we have a JWT token in localStorage then treat user as authenticated
const token = localStorage.getItem('token')
if (token) {
try {
const { username } = JSON.parse(localStorage.getItem('token'))
store.dispatch(authSuccess(username))
} catch (e) {
console.log(e)
}
}
render()
================================================
FILE: client/app/components/ActionPanel.js
================================================
import React from 'react'
// TODO move to own component called pocket cards
import Card from './Card'
const getPocketCards = cards =>
cards !== undefined && cards !== null ? cards.map(card => {
const rank = card.get('rank')
const suit = card.get('suit')
return ()
}) : ''
const ActionPanel = ({
updateBetValue,
betValue,
bet,
raise,
call,
fold,
check,
postSmallBlind,
postBigBlind,
sitDown,
leaveGameSeat,
userPocketCards,
gameStage,
sitIn,
bigBlind,
maxCurrBet,
isTurnToAct,
availableActions,
userPlayer
}) => {
console.log('available actions', availableActions)
console.log(gameStage)
const preDealActions =
gameStage === "PreDeal" ?
{availableActions.includes("PostBigBlind") ?
: ''}
{availableActions.includes("PostSmallBlind") ?
: ' '}
{userPlayer ? '' : }
{userPlayer && (userPlayer.get("_playerState") === "SatOut") ? : ''}
{userPlayer ? : ' '}
: '';
let minBet = maxCurrBet >= bigBlind ? 2 * maxCurrBet : bigBlind
return (
)
}
export default ActionPanel
================================================
FILE: client/app/components/App.js
================================================
/**
*
* App
*
* This component is the skeleton around the actual pages, and should only
* contain code that should be seen on all pages. (e.g. navigation bar)
*/
import React from 'react'
import { Helmet } from 'react-helmet'
import { Switch, Route } from 'react-router-dom'
import HomeContainer from '../containers/HomeContainer'
import NavBarContainer from '../containers/NavBarContainer'
import SignUpFormContainer from '../containers/SignUpFormContainer'
import SignInFormContainer from '../containers/SignInFormContainer'
import LobbyContainer from '../containers/LobbyContainer'
import GameContainer from '../containers/GameContainer'
import ProfileContainer from '../containers/ProfileContainer'
import Footer from './Footer'
import NotFoundPage from './NotFoundPage'
import Signout from './Signout'
const App = ({ username }) => (
You signed in with another tab or window. Reload to refresh your session.You signed out in another tab or window. Reload to refresh your session.
Press h to open a hovercard with more details.
================================================
FILE: docker-compose.yml
================================================
version: "3.5"
services:
db:
image: postgres:9.4
environment:
- DB_USER=postgres
- DB_PASS=postgres
- DB_NAME=poker
- POSTGRES_PASSWORD=postgres
# volumes:
# - db-data:/var/lib/postgresql/data
restart: on-failure
networks:
- backend
redis:
image: redis:5.0-rc4-alpine
networks:
- backend
restart: on-failure
volumes:
- redis-data:/var/lib/redis
server:
build: ./server
environment:
- dbConnStr=host=db port=5432 user=postgres dbname=postgres password=postgres
- secret=aw4-4z0ds21c970dasdak4dm=9jhkbn8da268tkj7=rsfdaf92x88
- redisHost=redis
depends_on:
- db
- redis
ports:
- "8000:8000"
- "5000:5000"
restart: on-failure
networks:
- backend
client:
build: ./client
restart: on-failure
environment:
- HOST=0.0.0.0
ports:
- target: 3000
published: 3000
protocol: tcp
mode: host
networks:
backend:
volumes:
db-data:
redis-data:
================================================
FILE: server/.dev.env
================================================
dbConnStr='port=5432 user=postgres dbname=postgres password=postgres'
port=8000
secret="wwaaifidsa9109f0dasfda-=2-13"
================================================
FILE: server/.dockerignore
================================================
.dockerignore
.gitignore
.stack-work
Dockerfile
================================================
FILE: server/.gitignore
================================================
poker-server.cabal
*~
.env
build
dist
dist-*
cabal-dev
*.o
*.hi
*.chi
*.chs.h
*.dyn_o
*.dyn_hi
.hpc
.hsenv
.cabal-sandbox/
cabal.sandbox.config
*.prof
*.aux
*.hp
*.eventlog
.stack-work/
cabal.project.local
cabal.project.local~
.HTF/
.ghc.environment.*
.prod.env
================================================
FILE: server/.projectile
================================================
================================================
FILE: server/ChangeLog.md
================================================
# Changelog for poker-server
## Unreleased changes
================================================
FILE: server/Dockerfile
================================================
FROM fpco/stack-build-small
RUN mkdir -p /app
COPY . /app
WORKDIR /app
RUN apt-get update && \
apt-get install libpq-dev lzma-dev libpq-dev -yy
RUN stack build --only-dependencies
RUN stack build
CMD stack run
================================================
FILE: server/README.md
================================================
# Server
================================================
FILE: server/Setup.hs
================================================
import Distribution.Simple
main = defaultMain
================================================
FILE: server/UNLICENSE.txt
================================================
This is free and unencumbered software released into the public domain.
Anyone is free to copy, modify, publish, use, compile, sell, or
distribute this software, either in source code form or as a compiled
binary, for any purpose, commercial or non-commercial, and by any
means.
In jurisdictions that recognize copyright laws, the author or authors
of this software dedicate any and all copyright interest in the
software to the public domain. We make this dedication for the benefit
of the public at large and to the detriment of our heirs and
successors. We intend this dedication to be an overt act of
relinquishment in perpetuity of all present and future rights to this
software under copyright law.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR
OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.
For more information, please refer to
================================================
FILE: server/app/Main.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Concurrent.Async
import qualified Data.ByteString.Lazy as BL
import Data.Text.Encoding as TSE
import Database.Redis ( defaultConnectInfo )
import Network.Wai.Handler.Warp
import Prelude
import qualified System.Remote.Monitoring as EKG
import qualified Data.ByteString.Lazy.Char8 as C
import API
import Database
import Env
import Socket
import Crypto.JWT
import Data.Proxy
import Types
main :: IO ((), ())
main = do
dbConnString <- getDBConnStrFromEnv
userAPIPort <- getAuthAPIPort defaultUserAPIPort
socketAPIPort <- getSocketAPIPort defaultSocketAPIPort
redisConfig <- getRedisHostFromEnv defaultRedisHost
print "REDIS config: "
print redisConfig
secretKey <- getSecretKey
let runSocketAPI =
runSocketServer secretKey socketAPIPort dbConnString redisConfig
app' = app secretKey dbConnString redisConfig
settings = setPort userAPIPort (setHost "0.0.0.0" defaultSettings)
migrateDB dbConnString
ekg <- runMonitoringServer
concurrently (runSettings settings app') runSocketAPI
where
defaultUserAPIPort = 8000
defaultSocketAPIPort = 5000
defaultRedisHost = "localhost"
defaultMonitoringServerAddress = "localhost"
defaultMonitoringServerPort = 9999
runMonitoringServer =
EKG.forkServer defaultMonitoringServerAddress defaultMonitoringServerPort
================================================
FILE: server/bootstrap.sh
================================================
# install virtual env and python
# activate python virtual env
virtualenv venv
~ source venv/bin/activate
# install ansible
sudo dnf install ansible
pip install docker-py boto
# install aws-cli
# Give executable permissions to the
# script which dynamically retrieves
# AWS EC2 instance inventory
chmod +x ansible/inventory/ec2.py
# Environment variables to the AWS EC2 inventory management script
#
#
# Our EC2 dynamic inventory script has the file name ec2.py
#
# This variable tells Ansible to use the dynamic
# EC2 script instead of a static /etc/ansible/hosts file.
export EC2_INI_PATH=./ansible/inventory/ec2.ini
# This variable tells ec2.py where the ec2.ini config file is located.
export ANSIBLE_INVENTORY=./ansible/inventory/ec2.py
================================================
FILE: server/deploy-server.sh
================================================
#!/bin/bash
## First arg to the bashfile must be the path to the key file to SSH into the EC2 host(s)
##
## Build and push new docker image to AWS ECR then pull and run new image in EC2 instance.
## Ensure AWS credentials are set in environment or the ansible playbook will fail to login to AWS
if [ $# -eq 0 ]
then
echo "You forgot to speciffy the path to the key file to authenticate the SSH connection"
fi
sudo -H pip install pip==18.0.0 \
&& sudo -H pip uninstall --yes setuptools \
&& sudo -H pip install 'setuptools<20.2' --ignore-installed \
&& sudo -H pip install 'requests[security]' --ignore-installed \
&& sudo -H pip install boto awscli ansible docker-py --ignore-installed \
&& ANSIBLE_CONFIG=ansible/ansible.cfg ansible-playbook ansible/push-new-image.yml ansible/deploy-image.yml --key-file=$1 -vvvv
================================================
FILE: server/deploy.sh
================================================
#!/usr/bin/env bash
set -o errexit
set -o pipefail
set -o nounset
# Location of executable
BUILD_DIR="./build"
BINARY_PATH=$BUILD_DIR"/poker-server-exe"
# Where we deploy
HOST="34.244.29.59"
REMOTE="ubuntu@"$HOST
RUN="sudo /opt/server/server-exe"
serverHealthCheck(){
local url="https://tenpoker.co.uk/lobby"
local statusCode=`echo $(curl -s -o /dev/null -w "%{http_code}" $url)`
if [[ "$statusCode" != 2* ]] && [[ "$statusCode" != 0* ]]; then
echo "Error: Server responded with http status: $statusCode" # if the content of statusCode isn't a "2xx" print the error.
fi
if [[ "$statusCode" = 0* ]]; then
echo "Error: Server unreachable: $statusCode" # connection refused
fi
if [[ "$statusCode" = 2* ]]; then
echo "Success: Server responded with http status: $statusCode"
fi
}
# compile binrary
stack build --copy-bins --local-bin-path $BUILD_DIR
ssh -i ~/.ssh/id_rsa $REMOTE sudo "systemctl stop server.service"
# copy server binary to remote
scp -i ~/.ssh/id_rsa $BINARY_PATH $REMOTE:/opt/server
# restart server using systemd
ssh -i ~/.ssh/id_rsa $REMOTE sudo "systemctl start server.service"
serverHealthCheck
================================================
FILE: server/docs/lobbyAPI.md
================================================
## POST /gooby
### Request:
- Supported content types are:
- `application/json;charset=utf-8`
- `application/json`
- Sample User (`application/json;charset=utf-8`, `application/json`):
```javascript
{"email":"gooby@g.com","username":"Tom","chips":2000,"password":"n84!@R5G"}
```
### Response:
- Status code 200
- Headers: []
- Supported content types are:
- `application/json;charset=utf-8`
- `application/json`
- Sample User (`application/json;charset=utf-8`, `application/json`):
```javascript
1
```
================================================
FILE: server/docs/socket.md
================================================
{"tag":"subscribeToTable","contents":"Black"}
{"tag":"TakeSeat","contents":["Black",3000]}
{"tag":"GameMove","contents":["Black",{"tag":"PostBlind","contents":"SmallBlind"}]}
{"tag":"GameMove","contents":["Black",{"tag":"PostBlind","contents":"BigBlind"}]}
{"tag":"GameMove","contents":["Black",{"tag":"Call"}]}
{"tag":"GameMove","contents":["Black",{"tag":"Check"}]}
{"tag":"GameMove","contents":["Black",{"tag":"Bet","contents":100}]}
{"tag":"LeaveSeat","contents":"Black"}
================================================
FILE: server/docs/userAPI.md
================================================
## POST /register
### Request:
- Supported content types are:
- `application/json;charset=utf-8`
- `application/json`
- Sample Register (`application/json;charset=utf-8`, `application/json`):
```javascript
{
newUsername: "Argo",
newEmail: "gooby@goo.com",
newPassword: "password123"
}
```
### Response:
- Supported content types are:
- `application/json;charset=utf-8`
- `application/json`
- Sample ReturnToken (`application/json;charset=utf-8`, `application/json`):
```javascript
{
"access_token": "eyJhbGciOiJIUzI1NiIs",
"expiration": 3600,
"refresh_token": "EwMIjImdgoeswazNQx"
}
```
## POST /login
### Request:
- Supported content types are:
- `application/json;charset=utf-8`
- `application/json`
- Sample Login (`application/json;charset=utf-8`, `application/json`):
```javascript
{
loginUsername: "gooby",
loginPassword: "password123"
}
```
### Response:
- Supported content types are:
- `application/json;charset=utf-8`
- `application/json`
- Sample ReturnToken (`application/json;charset=utf-8`, `application/json`):
```javascript
{
"access_token": "eyJhbGciOiJIUzI1NiIs",
"expiration": 3600,
"refresh_token": "EwMIjImdgoeswazNQx"
}
```
## GET /profile
### Request:
- Supported content types are:
- `application/json;charset=utf-8`
- `application/json`
- Headers:
- Authorization: eyJhbGciOiJIUzI1NiIs
Ensure access token is in Authorization header
### Response:
- Supported content types are:
- `application/json;charset=utf-8`
- `application/json`
- Sample ReturnToken (`application/json;charset=utf-8`, `application/json`):
```javascript
{
"proChips": 3000,
"proUsername": "Argo",
"proEmail": "gooby@goo.com"
}
```
================================================
FILE: server/package.yaml
================================================
name: poker-server
version: 0.1.0.0
github: "githubuser/poker-server"
license: Unlicense
author: "therewillbecode"
maintainer: "tomw08@gmail.com"
copyright: "2019 Tom Chambrier"
extra-source-files:
- README.md
- ChangeLog.md
description: A Poker Server Built With Haskell
dependencies:
- base >= 4.12 && < 5
- adjunctions
- distributive
- async
- aeson
- bytestring
- comonad
- free
- hedis
- ekg
- containers
- cryptohash
- hashable
- jose
- persistent
- persistent-postgresql
- persistent-template
- time
- servant
- servant-server
- servant-auth
- servant-auth-server
- servant-auth-client
- servant-foreign
- servant-options
- servant-websockets
- pipes
- pipes-aeson
- pipes-concurrency
- pipes-parse
- transformers
- random
- text
- wai
- wai-extra
- wai-logger
- wai-cors
- websockets
- pretty-simple
- utf8-string
- split
- stm
- MonadRandom
- monad-logger
- mtl
- jwt
- listsafe
- warp
- lens
- vector
library:
source-dirs: src
exposed-modules:
- API
- Bots
- Database
- Schema
- Env
- Types
- Poker.Poker
- Poker.Game.Actions
- Poker.ActionValidation
- Poker.Types
- Poker.Game.Blinds
- Poker.Game.Game
- Poker.Game.Hands
- Poker.Game.Utils
- Poker.Game.Privacy
- Socket
- Socket.Table
executables:
poker-server-exe:
main: Main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- poker-server
tests:
spec:
main: Spec.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- poker-server
- hspec
- hedgehog
- hspec-hedgehog
================================================
FILE: server/ping.sh
================================================
#!/usr/bin/env bash
set -o errexit
set -o pipefail
set -o nounset
BINARY_PATH=".stack-work/dist/x86_64-linux/Cabal-2.4.0.1/build/poker-server-exe/poker-server-exe"
HOST="34.244.29.59"
REMOTE="ubuntu@"$HOST
RUN="sudo /opt/server/server-exe"
serverHealthCheck(){
local url="https://tenpoker.co.uk/lobby"
local statusCode=`echo $(curl -s -o /dev/null -w "%{http_code}" $url)`
if [[ "$statusCode" != 2* ]] && [[ "$statusCode" != 0* ]]; then
echo "Error: Server responded with http status: $statusCode" # if the content of statusCode isn't a "2xx" print the error.
fi
if [[ "$statusCode" = 0* ]]; then
echo "Error: Server unreachable: $statusCode" # connection refused
fi
if [[ "$statusCode" = 2* ]]; then
echo "Success: Server responded with http status: $statusCode"
fi
}
serverHealthCheck
================================================
FILE: server/provision.sh
================================================
#!/usr/bin/env bash
set -o errexit
set -o pipefail
set -o nounset
REMOTE="ubuntu@34.244.29.59"
INSTALL_SYS_DEPENDENCIES="sudo apt-get update && sudo apt-get install -yy build-essential lzma-dev libpq-dev"
ssh -i ~/Downloads/tenprod.pem $REMOTE sudo $INSTALL_SYS_DEPENDENCIES
# create release dir and give ubuntu user permissions
ssh -i ~/.ssh/id_rsa $REMOTE sudo "sudo mkdir -pv /opt/server && sudo chown ubuntu /opt/server" -v
# give ubuntu user ownership of systemd service file dir
ssh -i ~/.ssh/id_rsa $REMOTE sudo "sudo chown ubuntu /etc/systemd/system" -v
# copy systemd service conf file to remote
scp -i ~/.ssh/id_rsa "server.service" $REMOTE:/etc/systemd/system
ssh -i ~/.ssh/id_rsa $REMOTE "sudo systemctl enable server.service"
scp -i ~/.ssh/id_rsa ".prod.env" $REMOTE:/etc/systemd/system/prod.env
================================================
FILE: server/server.service
================================================
[Unit]
Description=server
[Service]
Type=simple
ExecStart=/opt/server/poker-server-exe
Restart=always
User=ubuntu
EnvironmentFile=/etc/systemd/system/prod.env
[Install]
WantedBy=default.target
================================================
FILE: server/shell.nix
================================================
{ nixpkgs ? import {}, compiler ? "default", doBenchmark ? false }:
let
inherit (nixpkgs) pkgs;
f = { mkDerivation, adjunctions, aeson, async, base, bytestring
, comonad, containers, cryptohash, distributive, ekg, free
, hashable, hedgehog, hedis, hpack, hspec, hspec-hedgehog, jose
, jwt, lens, lib, listsafe, monad-logger, MonadRandom, mtl
, persistent, persistent-postgresql, persistent-template, pipes
, pipes-aeson, pipes-concurrency, pipes-parse, pretty-simple
, random, servant, servant-auth, servant-auth-client
, servant-auth-server, servant-foreign, servant-options
, servant-server, servant-websockets, split, stm, text, time
, transformers, utf8-string, vector, wai, wai-cors, wai-extra
, wai-logger, warp, websockets
}:
mkDerivation {
pname = "poker-server";
version = "0.1.0.0";
src = ./.;
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
adjunctions aeson async base bytestring comonad containers
cryptohash distributive ekg free hashable hedis jose jwt lens
listsafe monad-logger MonadRandom mtl persistent
persistent-postgresql persistent-template pipes pipes-aeson
pipes-concurrency pipes-parse pretty-simple random servant
servant-auth servant-auth-client servant-auth-server
servant-foreign servant-options servant-server servant-websockets
split stm text time transformers utf8-string vector wai wai-cors
wai-extra wai-logger warp websockets
];
libraryToolDepends = [ hpack ];
executableHaskellDepends = [
adjunctions aeson async base bytestring comonad containers
cryptohash distributive ekg free hashable hedis jose jwt lens
listsafe monad-logger MonadRandom mtl persistent
persistent-postgresql persistent-template pipes pipes-aeson
pipes-concurrency pipes-parse pretty-simple random servant
servant-auth servant-auth-client servant-auth-server
servant-foreign servant-options servant-server servant-websockets
split stm text time transformers utf8-string vector wai wai-cors
wai-extra wai-logger warp websockets
];
testHaskellDepends = [
adjunctions aeson async base bytestring comonad containers
cryptohash distributive ekg free hashable hedgehog hedis hspec
hspec-hedgehog jose jwt lens listsafe monad-logger MonadRandom mtl
persistent persistent-postgresql persistent-template pipes
pipes-aeson pipes-concurrency pipes-parse pretty-simple random
servant servant-auth servant-auth-client servant-auth-server
servant-foreign servant-options servant-server servant-websockets
split stm text time transformers utf8-string vector wai wai-cors
wai-extra wai-logger warp websockets
];
prePatch = "hpack";
homepage = "https://github.com/githubuser/poker-server#readme";
license = lib.licenses.unlicense;
};
haskellPackages = if compiler == "default"
then pkgs.haskellPackages
else pkgs.haskell.packages.${compiler};
variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
drv = variant (haskellPackages.callPackage f {});
in
if pkgs.lib.inNixShell then drv.env else drv
================================================
FILE: server/src/API.hs
================================================
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module API where
import Control.Concurrent (forkIO)
import Control.Lens ((&), (<>~))
import Control.Monad (forever)
import Control.Monad.Trans (liftIO)
import Crypto.JOSE.JWK (JWK)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Proxy (Proxy (..))
import qualified Data.Text as T
import Database.Persist.Postgresql (ConnectionString)
import Debug.Trace (traceShow)
import GHC.Generics (Generic)
import GHC.TypeLits
( ErrorMessage (Text),
KnownSymbol,
Symbol,
TypeError,
symbolVal,
)
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.Cors
( CorsResourcePolicy (corsRequestHeaders),
cors,
simpleCorsResourcePolicy,
)
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
import Network.Wai.Middleware.Servant.Options (provideOptions)
import Servant
( Application,
Context (EmptyContext, (:.)),
Get,
JSON,
NoContent,
Post,
Proxy (..),
ReqBody,
Server,
err401,
serveWithContext,
type (:<|>) (..),
type (:>),
)
import Servant.Auth.Server
( Auth,
AuthResult (Authenticated),
Cookie,
JWT,
JWTSettings,
ThrowAll (throwAll),
defaultCookieSettings,
defaultJWTSettings,
fromSecret,
)
import Servant.Foreign
( Arg (Arg, _argName, _argType),
HasForeign (..),
HasForeignType (..),
HeaderArg (HeaderArg),
PathSegment (PathSegment),
reqHeaders,
)
import Servant.Server
( Application,
Context (EmptyContext, (:.)),
Server,
err401,
serveWithContext,
)
import System.Environment (getArgs)
import Types
( Login,
RedisConfig,
Register,
ReturnToken,
UserProfile,
Username,
)
import Users
( fetchUserProfileHandler,
getLobbyHandler,
loginHandler,
registerUserHandler,
)
type API auths =
(Servant.Auth.Server.Auth auths Username :> ProtectedUsersAPI)
:<|> UnprotectedUsersAPI
type UnprotectedUsersAPI =
"login" :> ReqBody '[JSON] Login :> Post '[JSON] ReturnToken
:<|> "register" :> ReqBody '[JSON] Register :> Post '[JSON] ReturnToken
:<|> "lobby" :> Get '[JSON] NoContent
type ProtectedUsersAPI =
"profile" :> Get '[JSON] UserProfile
api :: Proxy (API '[JWT])
api = Proxy :: Proxy (API '[JWT])
protectedUsersApi :: Proxy ProtectedUsersAPI
protectedUsersApi = Proxy :: Proxy ProtectedUsersAPI
unprotectedUsersApi :: Proxy UnprotectedUsersAPI
unprotectedUsersApi = Proxy :: Proxy UnprotectedUsersAPI
app :: BS.ByteString -> ConnectionString -> RedisConfig -> Application
app secretKey connString redisConfig = addMiddleware $ serveWithAuth secretKey connString redisConfig
type Token = String
type family TokenHeaderName xs :: Symbol where
TokenHeaderName (Cookie ': xs) = "X-XSRF-TOKEN"
TokenHeaderName (JWT ': xs) = "Authorization"
TokenHeaderName (x ': xs) = TokenHeaderName xs
TokenHeaderName '[] = TypeError (Text "Neither JWT nor cookie auth enabled")
instance
( TokenHeaderName auths ~ header,
KnownSymbol header,
HasForeignType lang ftype Token,
HasForeign lang ftype sub
) =>
HasForeign lang ftype (Auth auths a :> sub)
where
type Foreign ftype (Auth auths a :> sub) = Foreign ftype sub
foreignFor lang Proxy Proxy req =
foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg]
where
arg =
Arg
{ _argName = PathSegment . T.pack $ symbolVal @header Proxy,
_argType = token
}
token = typeFor lang (Proxy @ftype) (Proxy @Token)
subP = Proxy @sub
-- Adds JWT Authentication to our server
serveWithAuth :: BS.ByteString -> ConnectionString -> RedisConfig -> Application
serveWithAuth secretKey c r =
serveWithContext api cfg (server jwtCfg c r)
where
jwk = fromSecret secretKey
jwtCfg = defaultJWTSettings jwk
cfg = defaultCookieSettings :. jwtCfg :. EmptyContext
api = Proxy :: Proxy (API '[JWT]) -- API is a type synonym for our api - type is now concrete
server :: JWTSettings -> ConnectionString -> RedisConfig -> Server (API '[JWT])
server j c r = protectedUsersServer j c r :<|> unprotectedUsersServer j c r
unprotectedUsersServer :: JWTSettings -> ConnectionString -> RedisConfig -> Server UnprotectedUsersAPI
unprotectedUsersServer jwtSettings connString redisConfig =
loginHandler jwtSettings connString
:<|> registerUserHandler jwtSettings connString redisConfig
:<|> getLobbyHandler jwtSettings connString redisConfig
protectedUsersServer :: JWTSettings -> ConnectionString -> RedisConfig -> AuthResult Username -> Server ProtectedUsersAPI
protectedUsersServer j c r (Authenticated username') = fetchUserProfileHandler c username'
protectedUsersServer _ _ _ er = traceShow er (throwAll err401)
type Middleware = Application -> Application
addMiddleware :: Application -> Application
addMiddleware = logStdoutDev . cors (const $ Just policy) . (provideOptions api)
where
corsReqHeaders = ["content-type", "Access-Control-Allow-Origin", "POST", "GET", "*"]
policy = simpleCorsResourcePolicy {corsRequestHeaders = corsReqHeaders}
================================================
FILE: server/src/Bots.hs
================================================
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Bots where
import Control.Applicative ((<$>))
import Control.Concurrent (ThreadId, forkIO, threadDelay)
import Control.Concurrent.Async (async)
import Control.Concurrent.STM
( TChan,
TVar,
atomically,
dupTChan,
readTChan,
readTVarIO,
)
import Control.Concurrent.STM.TChan (TChan, dupTChan, readTChan)
import Control.Exception ()
import Control.Lens ((^.))
import Control.Monad
( Monad (return, (>>)),
forever,
mapM_,
unless,
when,
)
import Control.Monad.Except
( Monad (return, (>>)),
MonadIO (liftIO),
forever,
mapM_,
unless,
when,
)
import Control.Monad.Reader
( Monad (return, (>>)),
MonadIO (liftIO),
forever,
mapM_,
unless,
when,
)
import Control.Monad.STM (atomically)
import Control.Monad.State.Lazy
( Monad (return, (>>)),
MonadIO (liftIO),
forever,
mapM_,
unless,
when,
)
import Data.Either (Either (Left, Right), isRight)
import Data.Foldable (Foldable (length, null), mapM_)
import Data.Functor ((<$>))
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Maybe
import Data.Maybe (Maybe (..), maybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import Database (dbDepositChipsIntoPlay)
import Database.Persist.Postgresql (ConnectionString)
import qualified Network.WebSockets as WS
import Pipes
import Pipes.Concurrent
import qualified Pipes.Prelude as P
import Poker.ActionValidation (validateAction)
import Poker.Game.Blinds (blindRequiredByPlayer)
import Poker.Game.Game (doesPlayerHaveToAct, initPlayer)
import Poker.Game.Utils (getGamePlayer)
import Poker.Poker (initPlayer, runPlayerAction)
import Poker.Types
import Socket.Table (toGameInMailbox, updateTable')
import Socket.Types
( Err (GameErr),
MsgOut (NewGameState),
ServerState (..),
Table
( Table,
channel,
game,
gameInMailbox,
gameOutMailbox,
subscribers,
waitlist
),
)
import Socket.Utils (unLobby)
import System.Random (randomRIO)
import Text.Pretty.Simple (pPrint)
import Types ()
import Prelude
delayThenSeatPlayer ::
ConnectionString -> Int -> TVar ServerState -> Player -> IO ()
delayThenSeatPlayer dbConn delayDuration s p = do
_ <- threadDelay delayDuration
sitDownBot dbConn p s
bot1 :: Player
bot1 = initPlayer "1@1" 2000
bot2 :: Player
bot2 = initPlayer "2@2" 2000
bot3 :: Player
bot3 = initPlayer "3@3" 2000
bot4 :: Player
bot4 = initPlayer "101@101" 2000
bot5 :: Player
bot5 = initPlayer "102@102" 2000
startBotActionLoops ::
ConnectionString -> TVar ServerState -> Int -> [PlayerName] -> IO ()
startBotActionLoops db s playersToWaitFor botNames = do
threadDelay 2500000 -- 25 second delay so bots dont start game until all of them sat down
ServerState {..} <- readTVarIO s
case M.lookup tableName $ unLobby lobby of
Nothing -> error "TableDoesNotExist "
Just table@Table {..} -> do
mapM_ (botActionLoop db s gameOutMailbox playersToWaitFor) botNames
where
tableName = "Black"
botActionLoop ::
ConnectionString ->
TVar ServerState ->
Input Game ->
Int ->
PlayerName ->
IO ThreadId
botActionLoop dbConn s gameOutMailbox playersToWaitFor botName = forkIO $
forever $ do
runEffect $
fromInput gameOutMailbox
>-> do
g <- await
liftIO $
if (canStartGame g)
then runBotAction dbConn s g botName
else (actIfNeeded g botName)
where
canStartGame Game {..} =
_street == PreDeal && (length _players >= playersToWaitFor)
actIfNeeded g' pName' =
let hasToAct = doesPlayerHaveToAct pName' g'
in when (hasToAct || (isJust $ blindRequiredByPlayer g' pName')) $ do
runBotAction dbConn s g' pName'
runBotAction ::
ConnectionString -> TVar ServerState -> Game -> PlayerName -> IO ()
runBotAction dbConn serverStateTVar g pName = do
maybeAction <- getValidBotAction g pName
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
liftIO $ async $ toGameInMailbox serverStateTVar tableName g
liftIO $ atomically $ updateTable' serverStateTVar tableName g
where
tableName = "Black"
chipsToSit = 2000
sitDownBot :: ConnectionString -> Player -> TVar ServerState -> IO ()
sitDownBot dbConn player@Player {..} serverStateTVar = do
s@ServerState {..} <- readTVarIO serverStateTVar
let gameMove = SitDown player
case M.lookup tableName $ unLobby lobby of
Nothing -> error "table doesnt exist" >> return ()
Just Table {..} -> do
let eitherNewGame = runPlayerAction game takeSeatAction
case eitherNewGame of
Left gameErr -> print $ GameErr gameErr
Right g -> do
dbDepositChipsIntoPlay dbConn _playerName chipsToSit
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
Just SmallBlind -> Just $ PlayerAction {action = PostBlind SmallBlind, ..}
Just BigBlind -> Just $ PlayerAction {action = PostBlind BigBlind, ..}
Nothing -> Nothing
| otherwise = do
betAmount' <- randomRIO (lowerBetBound, chipCount)
let possibleActions = actions _street $ unChips betAmount'
let actionsValidated = validateAction g name <$> possibleActions
let pNameActionPairs = zip possibleActions actionsValidated
let validActions = (<$>) fst $ filter (isRight . snd) pNameActionPairs
when (null validActions) (print g)
randIx <- randomRIO (0, length validActions - 1)
return $ Just $ PlayerAction {action = validActions !! randIx, ..}
where
actions :: Street -> Int -> [Action]
actions st chips
| st == PreDeal = [PostBlind BigBlind, PostBlind SmallBlind]
| otherwise = [Check, Call, Fold, Bet $ Chips chips, Raise $ Chips chips]
lowerBetBound = if (_maxBet > 0) then 2 * _maxBet else Chips _bigBlind
chipCount = maybe 0 (^. chips) (getGamePlayer g name)
================================================
FILE: server/src/Database.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Database where
import Control.Lens hiding ((<.))
import Control.Monad (void)
import Control.Monad.Except
( ExceptT,
MonadError (throwError),
MonadIO (liftIO),
void,
)
import Control.Monad.Logger
( LoggingT,
NoLoggingT,
runNoLoggingT,
runStderrLoggingT,
runStdoutLoggingT,
)
import Control.Monad.Reader (runReaderT)
import Data.ByteString.Char8
( pack,
unpack,
)
import Data.Int (Int64)
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Database.Persist
( Entity (Entity),
PersistEntity (Key),
PersistQueryRead (selectFirst),
PersistQueryWrite (updateWhere),
PersistStoreWrite (delete, insert),
(+=.),
(-=.),
(<.),
(=.),
(==.),
)
import Database.Persist.Postgresql
( ConnectionString,
SqlPersistT,
runMigration,
withPostgresqlConn,
)
import Database.Persist.Sql
( Entity (Entity),
PersistEntity (Key),
PersistQueryRead (selectFirst),
PersistQueryWrite (updateWhere),
PersistStoreWrite (delete, insert),
SqlPersistT,
fromSqlKey,
runMigration,
toSqlKey,
(+=.),
(-=.),
(<.),
(=.),
(==.),
)
import Database.Redis
( Redis,
connect,
runRedis,
setex,
)
import qualified Database.Redis as Redis
import Poker.Types (Game (..), unChips, unDeck)
import Schema
( EntityField
( TableEntityName,
UserEntityAvailableChips,
UserEntityChipsInPlay,
UserEntityEmail,
UserEntityPassword,
UserEntityUsername
),
GameEntity (..),
Key,
TableEntity (..),
UserEntity (..),
migrateAll,
)
import Types (Login (..), RedisConfig, Username (..))
runAction :: ConnectionString -> SqlPersistT (NoLoggingT IO) a -> IO a
runAction connectionString action =
runNoLoggingT $
withPostgresqlConn connectionString $ \backend ->
runReaderT action backend
migrateDB :: ConnectionString -> IO ()
migrateDB connString = runAction connString (runMigration migrateAll)
deleteUserPG :: ConnectionString -> Int64 -> IO ()
deleteUserPG connString uid = runAction connString (delete userKey)
where
userKey :: Key UserEntity
userKey = toSqlKey uid
dbGetUserByEmail :: ConnectionString -> Text -> IO (Maybe UserEntity)
dbGetUserByEmail connString email = do
maybeUserEntity <-
runAction
connString
(selectFirst [UserEntityEmail ==. email] [])
return $ case maybeUserEntity of
Just (Entity _ user) -> Just user
Nothing -> Nothing
dbGetUserByUsername :: ConnectionString -> Username -> IO (Maybe UserEntity)
dbGetUserByUsername connString (Username username) = do
maybeUserEntity <-
runAction
connString
(selectFirst [UserEntityUsername ==. username] [])
return $ case maybeUserEntity of
Just (Entity _ user) -> Just user
Nothing -> Nothing
dbRegisterUser ::
ConnectionString -> RedisConfig -> UserEntity -> ExceptT Text IO Int64
dbRegisterUser connString redisConfig userE@UserEntity {..} = do
emailAvailable <-
liftIO $
fetchUserByEmail connString redisConfig userEntityEmail
if isJust emailAvailable
then throwError "Email is Already Taken"
else do
usernameAvailable <-
liftIO $
dbGetUserByUsername connString (Username userEntityUsername)
if isJust usernameAvailable
then throwError "Username is Already Taken"
else liftIO $ fromSqlKey <$> runAction connString (insert userE)
dbGetUserByLogin :: ConnectionString -> Login -> IO (Maybe UserEntity)
dbGetUserByLogin connString Login {..} = do
maybeUser <-
runAction
connString
( selectFirst
[ UserEntityUsername ==. loginUsername,
UserEntityPassword ==. loginPassword
]
[]
)
return $ case maybeUser of
Just (Entity _ userE) -> Just userE
Nothing -> Nothing
fetchUserByEmail ::
ConnectionString -> RedisConfig -> Text -> IO (Maybe UserEntity)
fetchUserByEmail connString redisConfig email = do
maybeCachedUser <- liftIO $ redisFetchUserByEmail redisConfig email
case maybeCachedUser of
Just userE -> return $ Just userE
Nothing -> dbGetUserByEmail connString email
------- Redis --------
runRedisAction :: RedisConfig -> Redis a -> IO a
runRedisAction redisConfig action = do
connection <- connect redisConfig
runRedis connection action
-- we use emails instead of usernames for keys as users can change their usernames
cacheUser :: RedisConfig -> Text -> UserEntity -> IO ()
cacheUser redisConfig email userE =
runRedisAction redisConfig $
void $
setex
(pack . show $ email)
3600
(pack . show $ userE)
redisFetchUserByEmail :: RedisConfig -> Text -> IO (Maybe UserEntity)
redisFetchUserByEmail redisConfig email = runRedisAction redisConfig $ do
result <- Redis.get (pack . show $ email)
case result of
Right (Just userString) -> return $ Just (read . unpack $ userString)
_ -> return Nothing
------- Redis --------
-- Query is called at the end of every hand to update player balances
dbUpdateUsersChips :: ConnectionString -> [(Text, Int)] -> IO ()
dbUpdateUsersChips connString userChipCounts =
runAction
connString
( updateWhere
((UserEntityUsername ==.) . fst <$> userChipCounts)
((UserEntityAvailableChips =.) . snd <$> userChipCounts)
)
-- Query runs when player takes or leaves a seat at a game
dbDepositChipsIntoPlay :: ConnectionString -> Text -> Int -> IO ()
dbDepositChipsIntoPlay connString username chipsToAdd =
runAction
connString
( updateWhere
[UserEntityUsername ==. username]
[ UserEntityAvailableChips -=. chipsToAdd,
UserEntityChipsInPlay +=. chipsToAdd
]
)
dbWithdrawChipsFromPlay :: ConnectionString -> Text -> Int -> IO ()
dbWithdrawChipsFromPlay connString username chipsToAdd =
runAction
connString
( updateWhere
[UserEntityUsername ==. username]
[ UserEntityAvailableChips +=. chipsToAdd,
UserEntityChipsInPlay -=. chipsToAdd
]
)
dbGetTableEntity :: ConnectionString -> Text -> IO (Maybe (Entity TableEntity))
dbGetTableEntity connString tableName =
runAction connString (selectFirst [TableEntityName ==. tableName] [])
dbInsertTableEntity :: ConnectionString -> Text -> IO (Key TableEntity)
dbInsertTableEntity connString tableName =
runAction connString (insert (TableEntity {tableEntityName = tableName}))
dbInsertGame :: ConnectionString -> Key TableEntity -> Game -> IO ()
dbInsertGame connString tableId Game {..} = do
timestamp <- getCurrentTime
runAction connString (insert (gameEntity timestamp))
return ()
where
gameEntity timestamp =
GameEntity
{ gameEntityTableID = tableId,
gameEntityCreatedAt = timestamp,
gameEntityPlayers = _players,
gameEntityMinBuyInChips = unChips _minBuyInChips,
gameEntityMaxBuyInChips = unChips _maxBuyInChips,
gameEntityMaxPlayers = _maxPlayers,
gameEntityBoard = _board,
gameEntityWinners = _winners,
gameEntityWaitlist = _waitlist,
gameEntityDeck = unDeck _deck,
gameEntitySmallBlind = _smallBlind,
gameEntityBigBlind = _bigBlind,
gameEntityStreet = _street,
gameEntityPot = unChips _pot,
gameEntityMaxBet = unChips _maxBet,
gameEntityDealer = _dealer,
gameEntityCurrentPosToAct = _currentPosToAct
}
-- TODO - Ensure that chips in play are also taking into account when
-- determining which available chips counts to refill for plays with low balances
dbRefillAvailableChips :: ConnectionString -> Int -> IO ()
dbRefillAvailableChips connString refillThreshold =
runAction
connString
( updateWhere
[UserEntityAvailableChips <. refillThreshold]
[UserEntityAvailableChips =. refillThreshold]
)
================================================
FILE: server/src/Env.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Env where
import qualified Data.ByteString.Char8 as C
import Data.ByteString.UTF8 as BSU (fromString)
import Data.Maybe (Maybe (Just, Nothing), maybe)
import Data.Text (pack)
import Database.Redis
( ConnectInfo,
Redis,
connect,
connectHost,
connectPort,
defaultConnectInfo,
parseConnectInfo,
runRedis,
setex,
)
import System.Environment (lookupEnv)
import Text.Read (readMaybe)
import Web.JWT (secret)
import Prelude
getRedisHostFromEnv :: String -> IO ConnectInfo
getRedisHostFromEnv defaultHostName = do
maybeConnInfo <- lookupEnv "redisHost"
case maybeConnInfo of
Nothing -> do
print "couldn't parse redishost from env default used"
return defaultRedisConn
Just hostname -> do
print "Redis host name from env is: "
print hostname
return $ defaultConnectInfo {connectHost = hostname}
where
defaultRedisConn = defaultConnectInfo {connectHost = defaultHostName}
-- get the postgres connection string from dbConnStr env variable
getDBConnStrFromEnv :: IO C.ByteString
getDBConnStrFromEnv = do
dbConnStr <- lookupEnv "dbConnStr"
case dbConnStr of
Nothing -> error "Missing dbConnStr in env"
Just conn -> return $ C.pack conn
-- get the port from the userAPIPort env variable
getAuthAPIPort :: Int -> IO Int
getAuthAPIPort defaultPort = do
maybeEnvPort <- lookupEnv "authAPIPort"
case maybeEnvPort of
Nothing -> return defaultPort
Just port -> maybe (return defaultPort) return (readMaybe port)
-- get the port from the socketAPIPort env variable
getSocketAPIPort :: Int -> IO Int
getSocketAPIPort defaultPort = do
maybeEnvPort <- lookupEnv "socketPort"
case maybeEnvPort of
Nothing -> return defaultPort
Just port -> maybe (return defaultPort) return (readMaybe port)
-- get the secret key for signing JWT authentication tokens
getSecretKey :: IO C.ByteString
getSecretKey = do
maybeSecretKey <- lookupEnv "secret"
case maybeSecretKey of
Nothing -> error "Missing secret key in env"
Just s -> return $ BSU.fromString s
================================================
FILE: server/src/Poker/ActionValidation.hs
================================================
-- TODO - should factor out the hasEnoughChips check for each action and then just sequence it
-- inside the parent validateAction function with >>
--
-- Second TODo - remove use of fromJust
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Poker.ActionValidation where
import Control.Monad (when)
import Control.Monad.State.Lazy (when)
import Data.List (elemIndex, find)
import qualified Data.List.Safe as Safe
import Data.Maybe (fromJust, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Poker.Game.Blinds (blindRequiredByPlayer)
import Poker.Game.Game
( doesPlayerHaveToAct,
getWinners,
)
import Poker.Game.Utils
( getActivePlayers,
getGamePlayer,
getGamePlayerNames,
getGamePlayerState,
getPlayerNames,
)
import Poker.Types
validateAction :: Game -> PlayerName -> Action -> Either GameErr ()
validateAction game@Game {..} name' = \case
PostBlind blind ->
when (_maxBet > 0) (isPlayerActingOutOfTurn game name')
>> checkPlayerSatAtTable game name'
>> canPostBlind game name' blind
>> validateBlindAction game name' blind
Check -> isPlayerActingOutOfTurn game name' >> canCheck name' game
Fold -> isPlayerActingOutOfTurn game name' >> canFold name' game
Bet amount -> isPlayerActingOutOfTurn game name' >> canBet name' amount game
Raise amount ->
isPlayerActingOutOfTurn game name' >> canRaise name' amount game
Call -> isPlayerActingOutOfTurn game name' >> canCall name' game
Timeout -> canTimeout name' game
LeaveSeat' -> canLeaveSeat name' game
SitDown plyr -> canSit plyr game
SitOut -> checkPlayerSatAtTable game name' >> canSitOut name' game
SitIn -> checkPlayerSatAtTable game name' >> canSitIn name' game
ShowHand -> validateShowOrMuckHand game name' ShowHand
MuckHand -> validateShowOrMuckHand game name' MuckHand
-- Cannot post a blind to start a game unless at least two active players are present.
-- An active player is one whose playerStatus is set to In.
canPostBlind :: Game -> PlayerName -> Blind -> Either GameErr ()
canPostBlind game@Game {..} name blind
| _street /= PreDeal = Left $ InvalidMove name InvalidActionForStreet
| activePlayersCount < 2 =
Left $
InvalidMove name $
CannotPostBlind
"Cannot post blind unless a minimum of two active players are sat at table"
| otherwise = case blind of
BigBlind -> if unChips chipCount < _bigBlind then notEnoughChipsErr else Right ()
SmallBlind -> if unChips chipCount < _smallBlind then notEnoughChipsErr else Right ()
where
chipCount = _chips $ fromJust $ getGamePlayer game name
activePlayersCount = length $ getActivePlayers _players
notEnoughChipsErr = Left $ InvalidMove name NotEnoughChipsForAction
-- | The first player to post their blinds in the predeal stage can do it from any
-- position as long as there aren't enough players sat in to start a game
-- Therefore the acting in turn rule wont apply for that first move
-- when (< 2 players state set to sat in)
isPlayerActingOutOfTurn :: Game -> PlayerName -> Either GameErr ()
isPlayerActingOutOfTurn game@Game {..} name
| isNewGame = Right () -- Only Permit First Blind Posting to Be at Any Position When
-- starting new Game"
| currPosToActOutOfBounds = error "_currentPosToAct too big"
| isNothing _currentPosToAct && _street /= PreDeal = Left $ InvalidMove name $ NoPlayerCanAct
| fromJust _currentPosToAct < 0 = error "_currentPosToAct player < 0"
| otherwise = case name `elemIndex` gamePlayerNames of
Nothing -> Left $ NotAtTable name
Just pos ->
if doesPlayerHaveToAct name game
then Right ()
else
Left $
InvalidMove name $
OutOfTurn $
CurrentPlayerToActErr $
gamePlayerNames
!! fromJust _currentPosToAct
where
gamePlayerNames = getGamePlayerNames game
numberOfPlayersSatIn =
length $ filter (\Player {..} -> _playerStatus /= InHand Folded) _players
currPosToActOutOfBounds =
maybe False ((length _players - 1) <) _currentPosToAct
isNewGame = _street == PreDeal && isNothing _currentPosToAct
checkPlayerSatAtTable :: Game -> PlayerName -> Either GameErr ()
checkPlayerSatAtTable game@Game {..} name
| not atTable = Left $ NotAtTable name
| otherwise = Right ()
where
playerNames = getGamePlayerNames game
atTable = name `elem` playerNames
canTimeout :: PlayerName -> Game -> Either GameErr ()
canTimeout name game@Game {..}
| _street == Showdown = Left $ InvalidMove name InvalidActionForStreet
| otherwise = isPlayerActingOutOfTurn game name
canBet :: PlayerName -> Chips -> Game -> Either GameErr ()
canBet name amount game@Game {..}
| unChips amount < _bigBlind =
Left $ InvalidMove name BetLessThanBigBlind
| amount > chipCount =
Left $ InvalidMove name NotEnoughChipsForAction
| _street == Showdown || _street == PreDeal =
Left $ InvalidMove name InvalidActionForStreet
| _maxBet > 0 && _street /= PreFlop =
Left $
InvalidMove name $
CannotBetShouldRaiseInstead
"A bet can only be carried out if no preceding player has bet"
| otherwise =
Right ()
where
chipCount = _chips $ fromJust $ getGamePlayer game name
-- Keep in mind that a player can always raise all in,
-- even if their total chip count is less than what
-- a min-bet or min-raise would be.
canRaise :: PlayerName -> Chips -> Game -> Either GameErr ()
canRaise name amount game@Game {..}
| _street == Showdown || _street == PreDeal =
Left $ InvalidMove name InvalidActionForStreet
| _street == PreFlop && unChips _maxBet == _bigBlind =
Left $ InvalidMove name CannotRaiseShouldBetInstead -- a blind doesnt count as a sufficient bet to qualify a raise
| _maxBet == 0 =
Left $ InvalidMove name CannotRaiseShouldBetInstead
| amount < minRaise && amount /= chipCount =
Left $ InvalidMove name $ RaiseAmountBelowMinRaise $ unChips minRaise
| amount > chipCount =
Left $ InvalidMove name NotEnoughChipsForAction
| otherwise =
Right ()
where
minRaise = 2 * _maxBet
chipCount = _chips $ fromJust $ getGamePlayer game name
canCheck :: PlayerName -> Game -> Either GameErr ()
canCheck name Game {..}
| _street == PreFlop && fromCommittedChips _committed < _bigBlind =
Left $
InvalidMove name CannotCheckShouldCallRaiseOrFold
| _street == Showdown || _street == PreDeal =
Left $
InvalidMove name InvalidActionForStreet
| fromCommittedChips _committed < unChips _maxBet =
Left $
InvalidMove name CannotCheckShouldCallRaiseOrFold
| otherwise = Right ()
where
Player {..} = fromJust $ find (\Player {..} -> _playerName == name) _players
canFold :: PlayerName -> Game -> Either GameErr ()
canFold name Game {..}
| _street == Showdown || _street == PreDeal =
Left $
InvalidMove name InvalidActionForStreet
| otherwise = Right ()
canCall :: PlayerName -> Game -> Either GameErr ()
canCall name game@Game {..}
| _street == Showdown || _street == PreDeal =
Left $
InvalidMove name InvalidActionForStreet
| amountNeededToCall == 0 =
Left $
InvalidMove name CannotCallZeroAmountCheckOrBetInstead
| otherwise = Right ()
where
p = fromJust (getGamePlayer game name)
chipCount = _chips p
amountNeededToCall = _maxBet - _bet p
canSit :: Player -> Game -> Either GameErr ()
canSit player@Player {..} game@Game {..}
| _street /= PreDeal =
Left $
InvalidMove _playerName CannotSitDownOutsidePreDeal
| _playerName `elem` getPlayerNames _players =
Left $
AlreadySatAtTable _playerName
| _chips < _minBuyInChips = Left $ NotEnoughChips _playerName
| _chips > _maxBuyInChips = Left $ OverMaxChipsBuyIn _playerName
| length _players < _maxPlayers = Right ()
| otherwise = Left $ CannotSitAtFullTable _playerName
canSitOut :: PlayerName -> Game -> Either GameErr ()
canSitOut name game@Game {..}
| _street /= PreDeal = Left $ InvalidMove name CannotSitOutOutsidePreDeal
| isNothing currentState = Left $ NotAtTable name
| currentState == Just SatOut = Left $ InvalidMove name AlreadySatOut
| otherwise = Right ()
where
currentState = getGamePlayerState game name
canSitIn :: PlayerName -> Game -> Either GameErr ()
canSitIn name game@Game {..}
| _street /= PreDeal = Left $ InvalidMove name CannotSitInOutsidePreDeal
| isNothing pState = Left $ NotAtTable name
| maybe False satIn pState = Left $ InvalidMove name AlreadySatIn
| otherwise = Right ()
where
pState = getGamePlayerState game name
canLeaveSeat :: PlayerName -> Game -> Either GameErr ()
canLeaveSeat playerName game@Game {..}
| _street /= PreDeal =
Left $
InvalidMove playerName CannotLeaveSeatOutsidePreDeal
| playerName `notElem` getPlayerNames _players = Left $ NotAtTable playerName
| otherwise = Right ()
canJoinWaitList :: Player -> Game -> Either GameErr ()
canJoinWaitList player@Player {..} game@Game {..}
| _playerName `elem` _waitlist = Left $ AlreadyOnWaitlist _playerName
| otherwise = Right ()
validateBlindAction :: Game -> PlayerName -> Blind -> Either GameErr ()
validateBlindAction game@Game {..} playerName blind
| _street /= PreDeal =
Left $
InvalidMove playerName CannotPostBlindOutsidePreDeal
| otherwise = case getGamePlayer game playerName of
Nothing -> Left $ PlayerNotAtTable playerName
Just p@Player {..} -> case blindRequired of
Nothing -> Left $ InvalidMove playerName BlindNotRequired
Just SmallBlind ->
if blind == SmallBlind
then
if fromCommittedChips _committed >= _smallBlind
then Left $ InvalidMove playerName $ BlindAlreadyPosted SmallBlind
else Right ()
else Left $ InvalidMove playerName $ BlindRequiredErr SmallBlind
Just BigBlind ->
if blind == BigBlind
then
if fromCommittedChips _committed >= bigBlindValue
then Left $ InvalidMove playerName $ BlindAlreadyPosted BigBlind
else Right ()
else Left $ InvalidMove playerName $ BlindRequiredErr BigBlind
where
blindRequired = blindRequiredByPlayer game playerName
bigBlindValue = _smallBlind * 2
validateShowOrMuckHand :: Game -> PlayerName -> Action -> Either GameErr ()
validateShowOrMuckHand game@Game {..} name action =
checkPlayerSatAtTable game name
-- Should Tell us if everyone has folded to the given playerName
-- and the hand is over
canShowOrMuckHand :: PlayerName -> Game -> Either GameErr ()
canShowOrMuckHand name game@Game {..}
| _street /= Showdown = Left $ InvalidMove name InvalidActionForStreet
| otherwise = case _winners of
SinglePlayerShowdown winningPlayerName ->
if winningPlayerName == name
then Right ()
else
Left $
InvalidMove name $
CannotShowHandOrMuckHand
"Not winner of hand"
MultiPlayerShowdown _ ->
Left $
InvalidMove name $
CannotShowHandOrMuckHand
"Can only show or muck cards if winner of single player pot during showdown"
================================================
FILE: server/src/Poker/Game/Actions.hs
================================================
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
module Poker.Game.Actions where
import Control.Lens ((%~), (&), (+~), (-~), (.~), (<>~), (^.))
import Control.Monad.State (Functor)
import Data.Bool (Bool (False, True), bool)
import Data.Char (toLower)
import Data.List (filter, find, findIndex, sum)
import qualified Data.List.Safe as Safe
import Data.Maybe (fromJust)
import Poker.Game.Blinds (getPosNextBlind)
import Poker.Game.Game (nextPosToAct)
import Poker.Types
import Text.Read (readMaybe)
import Prelude
makeBet :: Bool -> Chips -> PlayerName -> Game -> Game
makeBet isCall betSize pName game@Game {..} =
updateMaxBet betSize game
& (players %~ placePlayerBet)
. (currentPosToAct %~ nextPosToAct _players)
. (pot +~ betSize)
where
placePlayerBet = (<$>) $
\p@Player {..} ->
if _playerName == pName
then placeBet isCall betSize p
else p
-- Update table maxBet and pot as well as player state and chip count
placeBet :: Bool -> Chips -> Player -> Player
placeBet isCall betSize plyr =
let chips' = plyr ^. chips
in plyr
& (chips -~ betSize)
. (bet <>~ betSize)
. (committed <>~ CommittedChips (unChips betSize))
. ( playerStatus
%~ nextPlayerStatus
chips'
(bool Call (Bet betSize) isCall)
)
nextPlayerStatus :: Chips -> Action -> PlayerStatus -> PlayerStatus
nextPlayerStatus (Chips 0) _ _ = InHand AllIn
nextPlayerStatus _ Fold _ = InHand Folded
nextPlayerStatus _ Check playerStatus =
InHand $ CanAct $ pure Checked
nextPlayerStatus _ Call playerStatus =
InHand $ CanAct $ pure $ MadeBet HasCalled
nextPlayerStatus _ (Bet size) playerStatus =
InHand $ CanAct $ pure $ MadeBet $ HasBet size
nextPlayerStatus _ (Raise size) playerStatus =
InHand $ CanAct $ pure $ MadeBet $ HasRaised size
nextPlayerStatus _ (PostBlind blind) playerStatus =
SatIn HasPlayedLastHand $ PostedBlind blind
nextPlayerStatus _ SitIn playerStatus =
SatIn HasPlayedLastHand NotPostedBlind
nextPlayerStatus _ Timeout playerStatus = playerStatus
nextPlayerStatus _ SitOut playerStatus = SatOut
nextPlayerStatus _ _ playerStatus = playerStatus
updateMaxBet :: Chips -> Game -> Game
updateMaxBet amount = maxBet %~ max amount
markInForHand :: Player -> Player
markInForHand = playerStatus .~ InHand (CanAct Nothing)
-- Will increment the game's current position to act to the next position
-- where a blind is required. Skipping players that do not have to post blinds
-- during the PreDeal phase of the game is desirable as by definition
-- the only possible players actions during the PreDeal phase are to either:
-- 1. Sit out of the game
-- 2. Post a blind.
postBlind :: Blind -> PlayerName -> Game -> Game
postBlind blind pName game@Game {..} =
-- hack because I dont know lens
let game' = makeBet False (Chips blindValue) pName game
in game'
& (pot +~ Chips blindValue)
. (currentPosToAct .~ pure nextRequiredBlindPos)
. (maxBet .~ newMaxBet)
where
isFirstBlind = sum ((\Player {..} -> _bet) <$> _players) == 0
gamePlayerNames = (\Player {..} -> _playerName) <$> _players
blindValue = if blind == SmallBlind then _smallBlind else _bigBlind
newMaxBet = Chips $ if blindValue > unChips _maxBet then blindValue else unChips _maxBet
positionOfBlindPoster = fromJust $ findIndex ((== pName) . (^. playerName)) _players
nextRequiredBlindPos = getPosNextBlind positionOfBlindPoster game
foldCards :: PlayerName -> Game -> Game
foldCards pName game@Game {..} =
game & (players .~ newPlayers) . (currentPosToAct %~ nextPosToAct _players)
where
newPlayers =
( \p@Player {..} ->
if _playerName == pName
then p & playerStatus %~ nextPlayerStatus _chips Fold
else p
)
<$> _players
call :: PlayerName -> Game -> Game
call pName game@Game {..} =
let game' = makeBet True callAmount pName game
in game'
& (currentPosToAct %~ nextPosToAct _players)
. (pot +~ callAmount)
where
player = fromJust $ find (\Player {..} -> _playerName == pName) _players
callAmount =
let maxBetShortfall = _maxBet - (player ^. bet)
playerChips = player ^. chips
in if maxBetShortfall > playerChips
then playerChips
else maxBetShortfall
check :: PlayerName -> Game -> Game
check pName game@Game {..} =
game & (players .~ newPlayers) . (currentPosToAct %~ nextPosToAct _players)
where
newPlayers =
( \p@Player {..} ->
if _playerName == pName
then p & playerStatus %~ nextPlayerStatus _chips Check
else p
)
<$> _players
-- Sets state of a given player to SatOut (sat-out)
-- In order to sit in again the player must post a blind
sitOut :: PlayerName -> Game -> Game
sitOut plyrName =
players
%~ (<$>)
( \p@Player {..} ->
if _playerName == plyrName
then Player {_playerStatus = SatOut, ..}
else p
)
sitIn :: PlayerName -> Game -> Game
sitIn plyrName =
players
%~ (<$>)
( \p@Player {..} ->
if _playerName == plyrName
then
Player
{ _playerStatus =
SatIn HasNotPlayedLastHand NotPostedBlind,
..
}
else p
)
seatPlayer :: Player -> Game -> Game
seatPlayer plyr = players <>~ pure plyr
joinWaitlist :: Player -> Game -> Game
joinWaitlist plyr = waitlist %~ (:) (plyr ^. playerName)
leaveSeat :: PlayerName -> Game -> Game
leaveSeat plyrName =
players %~ filter (\Player {..} -> plyrName /= _playerName)
================================================
FILE: server/src/Poker/Game/Blinds.hs
================================================
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
module Poker.Game.Blinds where
import Control.Lens ((%~), (&))
import Control.Monad.State ()
import Data.Char (toLower)
import Data.List (all, find, length, splitAt, tail, zip, zipWith)
import qualified Data.List.Safe as Safe
import Data.Maybe
import Data.Monoid ((<>))
import Data.Text (Text)
import Poker.Game.Utils
( getGamePlayer,
getPlayerNames,
getPlayerPosition,
modInc,
)
import Poker.Types
import Text.Read (readMaybe)
import Prelude
-- Gets the player position where the next required blind is
-- This function always us timeout players in the blinds stage if they don't post
-- the required blinds in order
getPosNextBlind :: Int -> Game -> Int
getPosNextBlind currIx game@Game {..} = nextIx
where
iplayers = zip [0 ..] _players
iplayers' = let (a, b) = splitAt currIx iplayers in b <> a
(nextIx, nextPlayer) =
fromJust $
find
( \(_, p@Player {..}) ->
isJust $ blindRequiredByPlayer game _playerName
)
(tail iplayers')
haveRequiredBlindsBeenPosted :: Game -> Bool
haveRequiredBlindsBeenPosted game@Game {..} =
all (== True) $
zipWith
( \requiredBlind Player {..} -> case requiredBlind of
Nothing -> True
Just BigBlind -> fromCommittedChips _committed == _bigBlind
Just SmallBlind -> fromCommittedChips _committed == _smallBlind
)
requiredBlinds
_players
where
requiredBlinds = getRequiredBlinds game
getRequiredBlinds :: Game -> [Maybe Blind]
getRequiredBlinds game@Game {..}
| _street /= PreDeal = []
| otherwise = blindRequiredByPlayer game <$> getPlayerNames _players
-- We use the list of required blinds to calculate if a player has posted
-- chips sufficient to be "In" for this hand.
activatePlayersWhenNoBlindNeeded :: [Maybe Blind] -> [Player] -> [Player]
activatePlayersWhenNoBlindNeeded = zipWith updatePlayer
where
updatePlayer blindReq Player {..} =
Player
{ _playerStatus =
if isNothing blindReq
then InHand (CanAct Nothing)
else _playerStatus,
..
}
-- Sets player state to in if they don't need to post blind
updatePlayersInHand :: Game -> Game
updatePlayersInHand game =
game & (players %~ activatePlayersWhenNoBlindNeeded (getRequiredBlinds game))
getSmallBlindPosition :: [Text] -> Int -> Int
getSmallBlindPosition playersSatIn dealerPos =
if length playersSatIn == 2
then dealerPos
else modInc incAmount dealerPos (length playersSatIn - 1)
where
incAmount = 1
-- if a player does not post their blind at the appropriate time then their state will be changed to
-- SatOut signifying that they have a seat but are now sat out
-- blind is required either if player is sitting in bigBlind or smallBlind position relative to dealer
-- or if their current playerStatus is set to Out
-- If no blind is required for the player to remain In for the next hand then we will return Nothing
blindRequiredByPlayer :: Game -> PlayerName -> Maybe Blind
blindRequiredByPlayer game playerName
| playerPosition == smallBlindPos =
Just SmallBlind
| playerPosition == bigBlindPos = Just BigBlind
| otherwise = Nothing
where
player = fromJust $ getGamePlayer game playerName
playerNames = getPlayerNames (_players game)
playerPosition = fromJust $ getPlayerPosition playerNames playerName
smallBlindPos = getSmallBlindPosition playerNames (_dealer game)
incAmount = 1
bigBlindPos = modInc incAmount smallBlindPos (length playerNames - 1)
================================================
FILE: server/src/Poker/Game/Game.hs
================================================
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
module Poker.Game.Game where
import Control.Lens (Field2 (_2), (%~), (&), (.~), (?~), (^.))
import Data.List (find, mapAccumR)
import qualified Data.List.Safe as Safe
import Data.Maybe (fromJust, isNothing)
import Data.Text (Text)
import Poker.Game.Blinds
import Poker.Game.Hands (value)
import Poker.Game.Utils
import Poker.Types
-- | Returns both the dealt players and remaining cards left in deck.
-- We return the new deck for the purposes of dealing the board cards
-- over the remaining course of the hand.
dealToPlayers :: Deck -> [Player] -> (Deck, [Player])
dealToPlayers =
mapAccumR
( \deck player ->
if player ^. playerStatus == InHand (CanAct Nothing)
then
let (pocketCs, remainingDeck) = dealPockets deck
in (remainingDeck, (pockets ?~ pocketCs) player)
else (deck, player)
)
dealPockets :: Deck -> (PocketCards, Deck)
dealPockets (Deck cs) = (PocketCards fstC sndC, Deck remainingDeck)
where
([fstC, sndC], remainingDeck) = splitAt 2 cs
dealBoardCards :: Int -> Game -> Game
dealBoardCards n game@Game {..} =
Game
{ _board = _board <> boardCards,
_deck = Deck shuffledDeck,
..
}
where
(boardCards, shuffledDeck) = splitAt n (unDeck _deck)
deal :: Game -> Game
deal game@Game {..} =
Game
{ _players = dealtPlayers,
_deck = remainingDeck,
..
}
where
(remainingDeck, dealtPlayers) = dealToPlayers _deck _players
-- Gets the next data constructor of the Street which represents
-- the name of the next game stage.
-- The term Street is poker terminology for hand stage.
getNextStreet :: Street -> Street
getNextStreet Showdown = minBound
getNextStreet _street = succ _street
initPlayer :: Text -> Int -> Player
initPlayer playerName chips =
Player
{ _pockets = Nothing,
_playerStatus = SatIn HasNotPlayedLastHand NotPostedBlind,
_playerName = playerName,
_bet = 0,
_possibleActions = [],
_committed = CommittedChips 0,
_chips = Chips chips
}
-- Everytime the game progresses to another street we need to
-- reset player statuses if the player has the possibility of acting
-- this street, that is the player has not folded or still has chips left
-- to make further bets.
nextHandStatus :: Chips -> PlayerStatus -> PlayerStatus
nextHandStatus (Chips 0) _ = SatOut
nextHandStatus _ a@(InHand _) = SatIn HasPlayedLastHand NotPostedBlind
nextHandStatus _ SatOut = SatIn HasNotPlayedLastHand NotPostedBlind
nextHandStatus _ (SatIn playedLastHand hasPostedBlind) = SatIn playedLastHand hasPostedBlind
-- Update active players states to prepare them for the next hand.
nextHandPlayer :: Player -> Player
nextHandPlayer Player {..} =
Player
{ _pockets = Nothing,
_playerStatus = nextHandStatus _chips _playerStatus,
_committed = CommittedChips 0,
..
}
nextHandPlayers :: Game -> Game
nextHandPlayers = players %~ (<$>) nextHandPlayer
-- Everytime the game progresses to another street we need to
-- reset player statuses if the player has the possibility of acting
-- this street, that is the player has not folded or still has chips left
-- to make further bets.
nextStreetStatus :: PlayerStatus -> PlayerStatus
nextStreetStatus (InHand AllIn) = InHand AllIn
nextStreetStatus (InHand Folded) = InHand Folded
nextStreetStatus (InHand _) = InHand $ CanAct Nothing
nextStreetStatus s = s
nextStreetPlayers :: Game -> Game
nextStreetPlayers = players %~ (<$>) (playerStatus %~ nextStreetStatus)
updatePosToAct :: Game -> Game
updatePosToAct g = g & currentPosToAct %~ nextPosToAct (_players g)
-- Unless in the scenario where everyone is all in
-- if no further player actions are possible (i.e betting has finished)
-- then actedThisTurn should be set to True for all active players in Hand.
-- This scenario occurs when all players or all but one players are all in.
--updatePlayerStatus :: Street -> PlayerStatus -> PlayerStatus
--updatePlayerStatus PreFlop = (bet .~ 0) . (Pla .~ False) <$> _players
-- When there are only two players in game (Heads Up) then the first player
-- to act PreFlop is the player at the dealer position.
-- First player to act is the player sitting to the right of the player
-- in the big blind position
progressToPreFlop :: Game -> Game
progressToPreFlop game@Game {..} =
game
& (street .~ PreFlop)
. (currentPosToAct .~ firstPosToAct)
. deal
. nextStreetPlayers
where
firstPosToAct
| countActive _players == 2 = pure _dealer
| -- When heads up dealer goes first
otherwise =
nextPosToAct _players _currentPosToAct
progressToFlop :: Game -> Game
progressToFlop game
| allButOneAllIn (_players game) =
game & (street .~ Flop) . dealBoardCards 3
| otherwise =
game
& (street .~ Flop)
. updatePosToAct
. (maxBet .~ 0)
. dealBoardCards 3
. nextStreetPlayers
progressToTurn :: Game -> Game
progressToTurn game
| allButOneAllIn (_players game) =
game & (street .~ Turn) . dealBoardCards 1
| otherwise =
game
& (street .~ Turn)
. (maxBet .~ 0)
. updatePosToAct
. dealBoardCards 1
. nextStreetPlayers
progressToRiver :: Game -> Game
progressToRiver game@Game {..}
| allButOneAllIn _players =
game & (street .~ River) . dealBoardCards 1
| otherwise =
game
& (street .~ River)
. (maxBet .~ 0)
. updatePosToAct
. dealBoardCards 1
. nextStreetPlayers
progressToShowdown :: Game -> Game
progressToShowdown game@Game {..} =
game
& (street .~ Showdown)
. (winners .~ winners')
. (currentPosToAct .~ Nothing)
. (players .~ awardedPlayers)
. (currentPosToAct .~ Nothing)
where
winners' = getWinners game
awardedPlayers = awardWinners _players (unChips _pot) winners'
-- need to give players the chips they are due and split pot if necessary
-- if only one active player then this is a result of everyone else folding
-- and they are awarded the entire pot
--
-- If only one player is active during the showdown stage then this means all other players
-- folded to him. The winning player then has the choice of whether to "muck"
-- (not show) his cards or not.
-- SinglePlayerShowdown occurs when everyone folds to one player
awardWinners :: [Player] -> Int -> Winners -> [Player]
awardWinners _players pot' = \case
MultiPlayerShowdown winners' ->
let chipsPerPlayer = pot' `div` length winners'
playerNames = snd <$> winners'
in ( \p@Player {..} ->
if _playerName `elem` playerNames
then Player {_chips = _chips <> (Chips chipsPerPlayer), ..}
else p
)
<$> _players
SinglePlayerShowdown _ ->
( \p@Player {..} ->
if p `elem` getActivePlayers _players
then Player {_chips = _chips <> (Chips pot'), ..}
else p
)
<$> _players
-- Can we show the active players' pocket cards to the world? Only if everyone is all in
-- (no more than 1 player not all (> 0 chips) per pot and every player has acted
canPubliciseActivesCards :: Game -> Bool
canPubliciseActivesCards g =
allButOneAllIn (_players g)
|| multiplayerShowdown
where
multiplayerShowdown =
_street g == Showdown && isMultiPlayerShowdown (_winners g)
-- TODO move players from waitlist to players list
-- TODO need to send msg to players on waitlist when a seat frees up to inform them
-- to choose a seat and set limit for them t pick one
-- TODO - have newBlindNeeded field which new players will initially be put into in order to
-- ensure they cant play without posting a blind before the blind position comes round to them
-- new players can of course post their blinds early. In the case of an early posting the initial
-- blind must be the big blind. After this 'early' blind or the posting of a normal blind in turn the
-- new player will be removed from the newBlindNeeded field and can play normally.
getNextHand :: Game -> Deck -> Game
getNextHand Game {..} shuffledDeck =
Game
{ _waitlist = newWaitlist,
_maxBet = 0,
_players = newPlayers,
_board = [],
_deck = shuffledDeck,
_winners = NoWinners,
_street = PreDeal,
_dealer = newDealer,
_pot = 0,
_currentPosToAct = Just nextPlayerToAct,
..
}
where
incAmount = 1
newDealer = modInc incAmount _dealer (length (getPlayersSatIn _players) - 1)
freeSeatsNo = _maxPlayers - length _players
newPlayers =
filterSatOutPlayers $
filterPlayersWithLtChips _bigBlind $
nextHandPlayer
<$> _players
newWaitlist = drop freeSeatsNo _waitlist
nextPlayerToAct = modInc incAmount newDealer (length newPlayers - 1)
-- | If all players have acted and their bets are equal
-- to the max bet then we can move to the next stage
haveAllPlayersActed :: Game -> Bool
haveAllPlayersActed g@Game {..}
| _street == Showdown = True
| _street == PreDeal = haveRequiredBlindsBeenPosted g
| length activePlayers < 2 = True
| otherwise = not (awaitingPlayerAction g)
where
activePlayers = getActivePlayers _players
awaitingPlayerAction :: Game -> Bool
awaitingPlayerAction Game {..} =
length activePlayers >= 2 && any (callNeeded _maxBet) activePlayers
where
activePlayers = getActivePlayers _players
callNeeded maxBet' Player {..} =
canAct _playerStatus == PlayerCanAct
&& unChips _chips > 0
&& _bet < maxBet'
-- If all players have folded apart from a remaining player then the mucked boolean
-- inside the player value will determine if we show the remaining players hand to the
-- table.
--
-- Otherwise we just get the handrankings of all active players.
getWinners :: Game -> Winners
getWinners game@Game {..} =
if allButOneFolded _players
then
SinglePlayerShowdown $
head $
flip (^.) playerName
<$> filter (\Player {..} -> _playerStatus /= InHand Folded) _players
else MultiPlayerShowdown $ maximums $ getHandRankings _players _board
-- Return the best hands and the active players (playerStatus of In) who hold
-- those hands.
--
-- If more than one player holds the same winning hand then the second part
-- of the tuple will consist of all the players holding the hand
getHandRankings ::
[Player] -> [Card] -> [((HandRank, PlayerShowdownHand), PlayerName)]
getHandRankings plyrs boardCards =
( \(showdownHand, Player {..}) ->
((_2 %~ PlayerShowdownHand) showdownHand, _playerName)
)
<$> map
( \plyr@Player {..} ->
let showHand = (++ boardCards) $ unPocketCards $ fromJust _pockets
in (value showHand, plyr)
)
remainingPlayersInHand
where
remainingPlayersInHand = getActivePlayers plyrs
-- During PreDeal we start timing out players who do not post their respective blinds
-- in turn after an initial blind has been posted
--
-- No player is forced to post first blind during PreDeal (blind betting stage).
--
-- Important to note that this function is mainly for asserting whether we need to
-- time a player's action. Player actions which are not mandatory such as posting a blind
-- to start a game will not be timed actions.
--
-- All possible player actions are either compulsary or optional. For example SitIn as a player is never forced to play a game. However if a player is already active in an
-- ongoing hand then all future actions for this hand will be mandatory and therefore timed so that a given
-- player cannot postpone the game through inactivity for an indefinite amount of time.
--
-- Optional actions as as SitIn (changing player state to In to denote that they are active this hand)
-- would return False in this function.
--
-- PostBlind actions are trickier. Depending on the context they will be compulsary or optional.
-- True is for a situation where the continued progression
-- of the game in a satisfactory timeframe is determined by the expediancy of the current
-- player's action.
doesPlayerHaveToAct :: Text -> Game -> Bool
doesPlayerHaveToAct playerName game@Game {..}
| length _players < 2 = False
| not $ inPositionToAct playerName game = False
| isNothing _currentPosToAct = False
| otherwise =
if currPosToActOutOfBounds
then error $ "_currentPosToAct too large " <> show game
else case _players Safe.!! fromJust _currentPosToAct of
Nothing -> False
Just Player {..}
| unChips _chips == 0 ->
False
| _street
== Showdown
|| countActive _players < 2
|| haveAllPlayersActed game
|| (PlayerCannotAct == canAct _playerStatus)
|| _street
== PreDeal && _maxBet
== 0 ->
False
| _street == PreDeal ->
_playerName
== playerName
&& ( isNothing $
blindRequiredByPlayer game playerName
)
| otherwise ->
_playerName == playerName
where
currPosToActOutOfBounds =
maybe False ((length _players - 1) <) _currentPosToAct
-- returns the index of the next active player with chips after the given current index who has chips
--
-- return a Nothing if everyone is all in and we cannot increment the position since
-- there are no players who can act
-- updates position to next player if there is another player who can act otherwise
-- return the same position
-- second param is the position we start from when calculating the next position to act
-- unless this is the beginning of the next stage then the initialPos == _currentPosToAct
nextIxPlayerToAct :: [Player] -> Maybe Int -> Maybe (Int, Player)
nextIxPlayerToAct ps = nextIPlayer
where
iplayers = zip [0 ..] ps
iplayers' currPosToAct =
let (a, b) = splitAt currPosToAct iplayers in b <> a
nextIPlayer = \case
Nothing -> Nothing
Just currPos ->
let nextIxPlayerToAct = tail $ iplayers' currPos
in find
(\(_, Player {..}) -> PlayerCanAct == canAct _playerStatus)
nextIxPlayerToAct
-- gets the position of the next player which needs to act
-- if currentPosToAct is already a Nothing then this means we are starting a new hand
-- and will just return the initial player to act for a new hand
nextPosToAct :: [Player] -> Maybe Int -> Maybe Int
nextPosToAct ps currPostToAct
| status == EveryoneFolded = Nothing
| status == EveryoneAllIn = Nothing
| status == NotAwaitingPlayerAction = Nothing
| otherwise = fst <$> nextIxPlayerToAct ps currPostToAct
where
activePs = getActivePlayers ps
activePCount = length activePs
status = bettingActionStatus ps
-- used to get the initial player to act when progressing to a new game stage
firstPosToAct :: Game -> Maybe Int
firstPosToAct g@Game {..}
| activePCount == 2 =
if _street == PreFlop
then firstPToAct _dealer
else firstPToAct 1
| otherwise = if _street == PreFlop then firstPToAct 3 else firstPToAct 1
where
activePs = getActivePlayers _players
activePCount = length activePs
incPosBy n = Just $ modInc n _dealer (activePCount - 1)
firstPToAct dealerIncAmount =
fst
<$> nextIxPlayerToAct
_players
(incPosBy (modDec dealerIncAmount activePCount))
isMultiPlayerShowdown :: Winners -> Bool
isMultiPlayerShowdown (MultiPlayerShowdown _) = True
isMultiPlayerShowdown _ = False
================================================
FILE: server/src/Poker/Game/Hands.hs
================================================
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Poker.Game.Hands where
import Data.Function (on)
import Data.List (foldl', groupBy, nubBy, sort, sortBy)
import Data.Ord (comparing)
import Poker.Types
( Card (rank, suit),
HandRank (..),
Rank (Ace, Five, Four, Three, Two),
)
type RankGroup = Int
value :: [Card] -> (HandRank, [Card])
value hand = maybe (ifNotFlush hand) ifFlush (maybeFlush hand)
ifNotFlush :: [Card] -> (HandRank, [Card])
ifNotFlush hand = maybe (checkGroups hand) (Straight,) (maybeStraight hand)
ifFlush :: [Card] -> (HandRank, [Card])
ifFlush hand =
maybe (Flush, take 5 hand) (StraightFlush,) (maybeStraight hand)
lastNelems :: Int -> [a] -> [a]
lastNelems n xs = foldl' (const . drop 1) xs (drop n xs)
maybeFlush :: [Card] -> Maybe [Card]
maybeFlush cs
| length cs' >= 5 = Just cs'
| otherwise = Nothing
where
sortBySuit = sortBy (comparing suit <> flip compare)
groupBySuit = groupBy ((==) `on` suit)
cs' = head $ sortByLength $ groupBySuit $ sortBySuit cs
maybeStraight :: [Card] -> Maybe [Card]
maybeStraight cards
| length cs'' >= 5 = Just (lastNelems 5 cs'')
| otherwise = maybeWheel cardsUniqRanks
where
cardsUniqRanks = nubBy ((==) `on` rank) cards
cs'' = head $ sortByLength $ groupBySuccCards $ sort cardsUniqRanks
maybeWheel :: [Card] -> Maybe [Card]
maybeWheel cards
| length filteredCards == 5 = Just filteredCards
| otherwise = Nothing
where
filteredCards =
(flip elem [Ace, Two, Three, Four, Five] . rank) `filter` cards
checkGroups :: [Card] -> (HandRank, [Card])
checkGroups hand = (hRank, cards)
where
groups = sortByLength $ groupBy ((==) `on` rank) $ sort hand
cards = take 5 $ concat groups
groupedRankLengths = length <$> groups
hRank = evalGroupedRanks groupedRankLengths
evalGroupedRanks :: [RankGroup] -> HandRank
evalGroupedRanks = \case
(4 : _) -> Quads
(3 : 2 : _) -> FullHouse
(3 : _) -> Trips
(2 : 2 : _) -> TwoPair
(2 : _) -> Pair
_ -> HighCard
groupBySuccCards :: [Card] -> [[Card]]
groupBySuccCards = foldr f []
where
f :: Card -> [[Card]] -> [[Card]]
f a [] = [[a]]
f a xs@(x : xs')
| succ (rank a) == rank (head x) = (a : x) : xs'
| otherwise = [a] : xs
sortByLength :: Ord a => [[a]] -> [[a]]
sortByLength = sortBy (flip (comparing length) <> flip compare)
================================================
FILE: server/src/Poker/Game/Privacy.hs
================================================
{-
Logic for excluding sensitive game data from game state.
-}
{-# LANGUAGE RecordWildCards #-}
module Poker.Game.Privacy where
import Control.Lens ((%~), (&), (.~))
import Data.Text (Text)
import Poker.Game.Game (canPubliciseActivesCards)
import Poker.Types
-- For players that are sat in game
excludeOtherPlayerCards :: PlayerName -> Game -> Game
excludeOtherPlayerCards playerName = excludePrivateCards $ Just playerName
-- -- For spectators who aren't in game
excludeAllPlayerCards :: Game -> Game
excludeAllPlayerCards = excludePrivateCards Nothing
-- Exclude player cards and Deck so spectators can't see private cards.
--
-- Takes an optional playerName. If no playerName is given then all private
-- cards are excluded. However if playerName is given then their cards
-- will not be excluded.
--
-- So if a game update is going to be sent to a user then we pass in his playerName
-- so that information that is private to him is not excluded from the
-- Game state (his pocket cards)
--
-- If everyone in the game is AllIn then their pocket cards should all be visible.
--
---- We show all active players cards in the case of every active player being all in
-- or during the final showdown stage of the game
--
-- If they are
-- then all the pocket cards held by players whose _playerStatus
-- is set to In (active and) are public and therefore not removed.
excludePrivateCards :: Maybe PlayerName -> Game -> Game
excludePrivateCards maybePlayerName game =
game & (players %~ (<$>) pocketCardsPrivacyModifier) . (deck .~ Deck [])
where
showAllActivesCards = canPubliciseActivesCards game
pocketCardsPrivacyModifier =
maybe
(updatePocketCardsForSpectator showAllActivesCards)
(updatePocketCardsForPlayer showAllActivesCards)
maybePlayerName
updatePocketCardsForSpectator :: Bool -> (Player -> Player)
updatePocketCardsForSpectator showAllActivesCards
| showAllActivesCards = \player@Player {..} ->
if _playerStatus /= InHand Folded then player else Player {_pockets = Nothing, ..}
| otherwise = \Player {..} -> Player {_pockets = Nothing, ..}
updatePocketCardsForPlayer :: Bool -> PlayerName -> (Player -> Player)
updatePocketCardsForPlayer showAllActivesCards playerName
| showAllActivesCards = \player@Player {..} ->
if (_playerStatus /= InHand Folded) || (_playerName == playerName)
then player
else Player {_pockets = Nothing, ..}
| otherwise = \player@Player {..} ->
if _playerName == playerName
then player
else Player {_pockets = Nothing, ..}
================================================
FILE: server/src/Poker/Game/Utils.hs
================================================
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
module Poker.Game.Utils where
import Control.Lens ((^.))
import Data.Bool (bool)
import Data.Foldable (find)
import Data.List (elemIndex, find)
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Text (Text)
import Poker.Types
import System.Random (Random (randomR), RandomGen)
-- | A standard deck of cards.
initialDeck :: Deck
initialDeck = Deck $ Card <$> [minBound ..] <*> [minBound ..]
-- Get a shuffled deck of cards.
shuffledDeck :: RandomGen g => g -> Deck
shuffledDeck gen = Deck <$> fst $ shuffle gen (unDeck initialDeck)
fisherYatesStep :: RandomGen g => (Map Int a, g) -> (Int, a) -> (Map Int a, g)
fisherYatesStep (m, gen) (i, x) =
((M.insert j x . M.insert i (m M.! j)) m, gen')
where
(j, gen') = randomR (0, i) gen
-- shuffle using the Fisher Yates algorithm
shuffle :: RandomGen g => g -> [a] -> ([a], g)
shuffle gen [] = ([], gen)
shuffle gen l =
toElems $
foldl fisherYatesStep (initial (head l) gen) (numerate (tail l))
where
toElems (x, y) = (M.elems x, y)
numerate = zip [1 ..]
initial x gen = (M.singleton 0 x, gen)
modInc :: Int -> Int -> Int -> Int
modInc incAmount num modulo
| incNum > modulo = 0
| otherwise = incNum
where
incNum = num + incAmount
modInc = incNum `mod` modulo
modDec :: Int -> Int -> Int
modDec num modulo
| decNum < modulo = 0
| otherwise = decNum
where
decNum = num - 1
modInc = decNum `mod` modulo
-- return players which have the ability to make further moves i.e not all in or folded
-- the distinction between sat in and active is important
-- if a player is sat out then there has been no historical participation in this hand
-- as there can be no future participation in this hand
-- whereas sat in means that the player has at the very least had some historical participation
-- in the current hand
getActivePlayers :: [Player] -> [Player]
getActivePlayers = filter ((==) PlayerCanAct . canAct . _playerStatus)
filterPlayersWithLtChips :: Int -> [Player] -> [Player]
filterPlayersWithLtChips count =
filter
( \Player {..} ->
unChips _chips >= count
)
filterSatOutPlayers :: [Player] -> [Player]
filterSatOutPlayers = filter (\Player {..} -> _playerStatus /= SatOut)
countActive :: [Player] -> Int
countActive = length . getActivePlayers
canAct :: PlayerStatus -> CanPlayerAct
canAct (InHand (CanAct _)) = PlayerCanAct
canAct _ = PlayerCannotAct
canPlayersAct :: Functor f => f Player -> f CanPlayerAct
canPlayersAct ps = canAct . _playerStatus <$> ps
canAnyPlayerAct :: [Player] -> Bool
canAnyPlayerAct = elem PlayerCanAct . canPlayersAct
bettingActionStatus :: [Player] -> BettingAction
bettingActionStatus ps
| allButOneFolded ps = EveryoneFolded
| playersNotAllIn ps == 1 = EveryoneAllIn
| canAnyPlayerAct ps = AwaitingPlayerAction
| not (canAnyPlayerAct ps) = NotAwaitingPlayerAction
| otherwise = error "undhandled guard"
allButOneAllIn :: [Player] -> Bool
allButOneAllIn = (== 1) . playersNotAllIn
playersNotAllIn :: [Player] -> Int
playersNotAllIn ps
| numPlayersIn < 2 = 0
| otherwise = numPlayersIn - numPlayersAllIn
where
numPlayersIn = length $ getActivePlayers ps
numPlayersAllIn =
length $ filter (\Player {..} -> _playerStatus == InHand AllIn) ps
-- The game should go straight to showdown if all but one players is In hand
allButOneFolded :: [Player] -> Bool
allButOneFolded ps = length playersInHand <= 1
where
playersInHand = filter ((== InHand Folded) . (^. playerStatus)) ps
-- get all players who are not currently sat out
getPlayersSatIn :: [Player] -> [Player]
getPlayersSatIn = filter ((/= SatOut) . (^. playerStatus))
-- player position is the order of a given player in the set of all players with a
-- playerStatus of In or in other words the players that are both sat at the table and active
-- return Nothing if the given playerName is not sat at table
getPlayerPosition :: [PlayerName] -> PlayerName -> Maybe Int
getPlayerPosition playersSatIn playerName = playerName `elemIndex` playersSatIn
getPlayerPosition' :: PlayerName -> [Player] -> Maybe Int
getPlayerPosition' playerName = flip getPlayerPosition playerName . getPlayerNames . getPlayersSatIn
getGameStage :: Game -> Street
getGameStage game = game ^. street
getGamePlayers :: Game -> [Player]
getGamePlayers game = game ^. players
getGamePlayer :: Game -> PlayerName -> Maybe Player
getGamePlayer game playerName =
find (\Player {..} -> _playerName == playerName) $ _players game
getGamePlayerState :: Game -> PlayerName -> Maybe PlayerStatus
getGamePlayerState game playerName = do
Player {..} <- getGamePlayer game playerName
return _playerStatus
getGamePlayerNames :: Game -> [Text]
getGamePlayerNames game = _playerName <$> _players game
getPlayerChipCounts :: Game -> [(Text, Int)]
getPlayerChipCounts Game {..} =
(\Player {..} -> (_playerName, unChips _chips)) <$> _players
getPlayerNames :: [Player] -> [Text]
getPlayerNames players = (^. playerName) <$> players
-- Nothing for currentPosToAct during Predeal means that the first blind
-- can be posted from any position as this is the first blind to get a new game started
-- on the otherhand a value of Just pos means that pos is the position that we require a blind to
-- be posted from next as a game is underway.
inPositionToAct :: PlayerName -> Game -> Bool
inPositionToAct playerName Game {..} =
case playerPos of
Nothing -> False
Just pos -> case _currentPosToAct of
Nothing -> _street == PreDeal -- Wheareas Nothing during Predeal means anyone can act
-- Nothing in currentPostToAct field after predeal means no player can act.
Just posToAct -> pos == posToAct
where
playerPos = getPlayerPosition' playerName _players
maximums :: Ord a => [(a, b)] -> [(a, b)]
maximums [] = []
maximums (x : xs) = foldl f [x] xs
where
f ys y = case fst (head ys) `compare` fst y of
GT -> ys
EQ -> y : ys
LT -> [y]
================================================
FILE: server/src/Poker/Poker.hs
================================================
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-
Public API for Poker Game Logic
-}
module Poker.Poker
( initialGameState,
initPlayer,
progressGame,
canProgressGame,
runPlayerAction,
handlePlayerTimeout,
getAllValidPlayerActions,
)
where
import Control.Lens ((^.))
import Data.Either (isRight)
import Data.Functor (($>))
import Data.Text (Text)
import Poker.ActionValidation (canCheck, validateAction)
import Poker.Game.Actions
( call,
check,
foldCards,
leaveSeat,
makeBet,
postBlind,
seatPlayer,
sitIn,
sitOut,
)
import Poker.Game.Blinds
( blindRequiredByPlayer,
haveRequiredBlindsBeenPosted,
)
import Poker.Game.Game
import Poker.Game.Utils
import Poker.Types
import System.Random (RandomGen)
import Text.Pretty.Simple (pPrint)
-- the function takes a player action and returns either a new game for a valid
-- player action or an err signifying an invalid player action with the reason why
-- if the current game stage is showdown then the next game state will have a newly shuffled
-- deck and pocket cards/ bets reset
runPlayerAction :: Game -> PlayerAction -> Either GameErr Game
runPlayerAction game playerAction'@PlayerAction {..} =
updatePlayersPossibleActions <$> handlePlayerAction game playerAction'
canProgressGame :: Game -> Bool
canProgressGame game@Game {..}
| length _players < 2 = False
| _street == Showdown = True
| _street == PreDeal && haveRequiredBlindsBeenPosted game = True
| _street == PreDeal && haveAllPlayersActed game = True
| otherwise = haveAllPlayersActed game
-- when no player action is possible we can can call this function to get the game
-- to the next stage.
-- When the stage is showdown there are no possible player actions so this function is called
-- to progress the game to the next hand.
-- A similar situation occurs when no further player action is possible but the game is not over
-- in other words more than one players are active and all or all but one are all in
progressGame :: RandomGen g => g -> Game -> Game
progressGame gen = updatePlayersPossibleActions . nextStage gen
nextStage :: RandomGen g => g -> Game -> Game
nextStage gen game@Game {..}
| _street == Showdown =
nextHand
| notEnoughPlayersToStartGame =
nextHand
| haveAllPlayersActed game
&& ( not (allButOneFolded _players)
|| (_street == PreDeal || _street == Showdown)
) =
case getNextStreet _street of
PreFlop -> progressToPreFlop game
Flop -> progressToFlop game
Turn -> progressToTurn game
River -> progressToRiver game
Showdown -> progressToShowdown game
PreDeal -> nextHand
| allButOneFolded _players && _street /= Showdown =
progressToShowdown game
| otherwise =
game
where
nextHand = getNextHand game (shuffledDeck gen)
numberPlayersSatIn = length $ getActivePlayers _players
notEnoughPlayersToStartGame =
_street == PreDeal && haveAllPlayersActed game && numberPlayersSatIn < 2
handlePlayerAction :: Game -> PlayerAction -> Either GameErr Game
handlePlayerAction game@Game {..} PlayerAction {..} = case action of
PostBlind blind ->
validateAction game name action $> postBlind blind name game
Fold -> validateAction game name action $> foldCards name game
Call -> validateAction game name action $> call name game
Raise amount -> validateAction game name action $> makeBet False amount name game
Check -> validateAction game name action $> check name game
Bet amount -> validateAction game name action $> makeBet False amount name game
SitDown player -> validateAction game name action $> seatPlayer player game
SitIn -> validateAction game name action $> sitIn name game
LeaveSeat' -> validateAction game name action $> leaveSeat name game
Timeout -> handlePlayerTimeout name game
handlePlayerTimeout :: PlayerName -> Game -> Either GameErr Game
handlePlayerTimeout name game@Game {..}
| playerCanCheck && handStarted =
validateAction game name Check $> check name game
| not playerCanCheck && handStarted =
validateAction game name Timeout $> foldCards name game
| not handStarted =
validateAction game name SitOut $> sitOut name game
where
handStarted = _street /= PreDeal
playerCanCheck = isRight $ canCheck name game
initialGameState :: Deck -> Game
initialGameState shuffledDeck =
Game
{ _players = [],
_waitlist = [],
_minBuyInChips = 1500,
_maxBuyInChips = 3000,
_maxPlayers = 6,
_dealer = 0,
_currentPosToAct = Nothing,
_board = [],
_deck = shuffledDeck,
_smallBlind = 25,
_bigBlind = 50,
_pot = 0,
_street = PreDeal,
_maxBet = 0,
_winners = NoWinners
}
updatePlayersPossibleActions :: Game -> Game
updatePlayersPossibleActions g@Game {..} =
Game
{ _players = updatedPlayers,
..
}
where
updatedPlayers =
( \Player {..} ->
Player {_possibleActions = getValidPlayerActions g _playerName, ..}
)
<$> _players
getAllValidPlayerActions :: Game -> [[Action]]
getAllValidPlayerActions g@Game {..} =
getValidPlayerActions g . _playerName <$> _players
getValidPlayerActions :: Game -> PlayerName -> [Action]
getValidPlayerActions g@Game {..} name
| length _players < 2 =
[]
| _street == PreDeal =
case blindRequiredByPlayer g name of
Just SmallBlind -> [PostBlind SmallBlind]
Just BigBlind -> [PostBlind BigBlind]
Nothing -> []
| otherwise =
let minRaise = 2 * _maxBet
possibleActions = actions _street $ unChips chipCount
in filter (isRight . validateAction g name) possibleActions
where
actions :: Street -> Int -> [Action]
actions st chips
| st == PreDeal = [PostBlind BigBlind, PostBlind SmallBlind]
| otherwise = [Check, Call, Fold, Bet $ Chips chips, Raise $ Chips chips]
lowerBetBound = if _maxBet > 0 then 2 * _maxBet else Chips _bigBlind
chipCount = maybe 0 (^. chips) (getGamePlayer g name)
panic = do
error "no valid actions"
================================================
FILE: server/src/Poker/Types.hs
================================================
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Poker.Types where
import Control.Lens (makeLenses)
import Data.Aeson (FromJSON, ToJSON)
import Data.Function (on)
import Data.Text (Text)
import qualified Data.Text.Lazy as LT
import Database.Persist.TH (derivePersistField)
import GHC.Base (NonEmpty)
import GHC.Generics (Generic)
import System.Random
data Rank
= Two
| Three
| Four
| Five
| Six
| Seven
| Eight
| Nine
| Ten
| Jack
| Queen
| King
| Ace
deriving (Eq, Read, Ord, Bounded, Enum, Generic, ToJSON, FromJSON)
instance Show Rank where
show x = case x of
Two -> "2"
Three -> "3"
Four -> "4"
Five -> "5"
Six -> "6"
Seven -> "7"
Eight -> "8"
Nine -> "9"
Ten -> "T"
Jack -> "J"
Queen -> "Q"
King -> "K"
Ace -> "A"
data Suit
= Clubs
| Diamonds
| Hearts
| Spades
deriving (Eq, Ord, Bounded, Enum, Read, Generic, ToJSON, FromJSON)
instance Show Suit where
show x = case x of
Clubs -> "♧ "
Diamonds -> "♢ "
Hearts -> "♡ "
Spades -> "♤ "
data Card = Card
{ rank :: Rank,
suit :: Suit
}
deriving (Eq, Read, Generic, ToJSON, FromJSON)
instance Ord Card where
compare = compare `on` rank
instance Show Card where
show (Card r s) = show r ++ show s
data HandRank
= HighCard
| Pair
| TwoPair
| Trips
| Straight
| Flush
| FullHouse
| Quads
| StraightFlush
deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON)
type Bet = Int
--data ActivePlayerState
-- = SatOut -- SatOut denotes a player that will not be dealt cards unless they send a postblinds action to the server
-- | Folded
-- | In
-- deriving (Eq, Show, Ord, Enum, Bounded, Read, Generic, ToJSON, FromJSON)
data PocketCards
= PocketCards Card Card
deriving (Show, Eq, Read, Ord, Generic, ToJSON, FromJSON)
unPocketCards :: PocketCards -> [Card]
unPocketCards (PocketCards c1 c2) = [c1, c2]
newtype Chips = Chips Int
deriving newtype (Num, Random)
deriving (Eq, Show, Ord, Read, Generic, ToJSON, FromJSON)
instance Semigroup Chips where
(<>) (Chips a) (Chips b) = Chips $ a + b
-- The amount of chips bet by the player this turn.
newtype CommittedChips = CommittedChips Int deriving (Eq, Show, Ord, Read, Generic, ToJSON, FromJSON)
instance Semigroup CommittedChips where
(<>) (CommittedChips a) (CommittedChips b) =
CommittedChips $ a + b
mkChips :: Int -> Maybe Chips
mkChips n
| n < 0 = Nothing
| otherwise = pure $ Chips n
unChips :: Chips -> Int
unChips (Chips n) = n
fromCommittedChips :: CommittedChips -> Int
fromCommittedChips (CommittedChips cs) = cs
data CanPlayerAct = PlayerCanAct | PlayerCannotAct
deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON)
-- WasNotInLastHand:
-- Sometimes a player joins an in progress game and thus are
-- not on BB or SB position. PlayerWasNotInLastHand denotes
-- the fact the new player can choose to post an 'extra' blind
-- to play immediately. Or the player can wait till the blind
-- comes around to them.
--
newtype RequiredBlind = RequiredBlind (Maybe Blind)
deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON)
data PlayedLastHand = HasNotPlayedLastHand | HasPlayedLastHand
deriving (Eq, Show, Read, Ord, Generic, ToJSON, FromJSON)
data HasPostedBlind = NotPostedBlind | PostedBlind Blind
deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON)
data Blind
= SmallBlind
| BigBlind
deriving (Show, Eq, Read, Ord, Generic, ToJSON, FromJSON)
data PlayerInHandStatus
= CanAct (Maybe LastBetOrCheck)
| Folded
| AllIn
deriving (Eq, Show, Read, Ord, Generic, ToJSON, FromJSON)
data HasBet = HasCalled | HasBet Chips | HasRaised Chips
deriving (Eq, Show, Read, Ord, Generic, ToJSON, FromJSON)
--betSize :: HasBet -> Int
--betSize = \case
-- HasCalled -> n
-- HasBet n -> n
-- HasRaised n -> n
data LastBetOrCheck = MadeBet HasBet | Checked
deriving (Eq, Show, Read, Ord, Generic, ToJSON, FromJSON)
satIn :: PlayerStatus -> Bool
satIn (SatIn _ _) = True
satIn _ = False
data PlayerStatus
= SatOut
| SatIn PlayedLastHand HasPostedBlind
| InHand PlayerInHandStatus
deriving (Eq, Show, Read, Ord, Generic, ToJSON, FromJSON)
data Player = Player
{ _pockets :: Maybe PocketCards,
_chips :: Chips,
_bet :: Chips,
_playerStatus :: PlayerStatus,
_committed :: CommittedChips,
_playerName :: Text,
_possibleActions :: [Action]
}
deriving (Eq, Show, Ord, Read, Generic, ToJSON, FromJSON)
--data HasActedThisStreet = HasActed | HasNotActed
-- deriving (Eq, Show, Ord, Read, Generic, ToJSON, FromJSON)
-- data GameStage = NotStarted | PostBlinds | HandUnderway Street
newtype PlayerPosition = PlayerPosition Int
data BettingAction
= AwaitingPlayerAction
| NotAwaitingPlayerAction
| EveryoneFolded
| EveryoneAllIn
deriving (Eq, Show, Ord, Read, Generic, ToJSON, FromJSON)
data Street
= PreDeal
| PreFlop
| Flop
| Turn
| River
| Showdown
deriving (Eq, Ord, Show, Read, Bounded, Enum, Generic, ToJSON, FromJSON)
-- Highest ranking hand for a given Player that is in the game
-- during the Showdown stage of the game (last stage)
newtype PlayerShowdownHand
= PlayerShowdownHand [Card]
deriving (Show, Eq, Read, Ord, Generic, ToJSON, FromJSON)
unPlayerShowdownHand :: PlayerShowdownHand -> [Card]
unPlayerShowdownHand (PlayerShowdownHand cards) = cards
-- Folded To Signifies a a single player pot where everyone has
-- folded to them in this case the hand ranking is irrelevant
-- and the winner takes all. Therefore the winner has the choice of showing
-- or mucking (hiding) their cards as they are the only player in the pot.
--
-- Whereas in a MultiPlayer showdown all players must show their cards
-- as hand rankings are needed to ascertain the winner of the pot.
data Winners
= MultiPlayerShowdown [((HandRank, PlayerShowdownHand), PlayerName)]
| SinglePlayerShowdown PlayerName -- occurs when everyone folds to one player
| NoWinners -- todo - remove this and wrap whole type in a Maybe
deriving (Show, Eq, Read, Ord, Generic, ToJSON, FromJSON)
newtype Deck
= Deck [Card]
deriving (Show, Eq, Read, Ord, Generic, ToJSON, FromJSON)
unDeck :: Deck -> [Card]
unDeck (Deck cards) = cards
-- Idea - Could generalise the project to become
-- a DSL for card game servers.
-- (Game [Card]) [Player] actions
-- With card games the rulechecking gets pretty nasty.
--
-- To tame the nastiness of validating game rules
-- we model the poker game as a products of mealy machines.
-- The table is a mealy machine and N players are N mealy machines.
-- So we have N machines for checking all players,
-- a few extra machines for checking the global rules
-- player is a mealy machine and game is a mealy machine?
-- like, this might be a good way to fight the complexity of building the whole state checker yourself
--
-- coding it ain't much hard either, but with having the composition abstracted out you kinda ensure that you don't forget about something when composing it manually
--
-- The key idea is
-- "small coherent parts of the ruleset to keep are different mealy machines"
--
-- We can then use property based testing to ensure invariants
-- hold between mealy machines. Also by modelling the game as a product
-- of machines it is easier to build game generators in PBT as we can
-- compose smaller generators which represent coherent rules of our game.
data Game = Game
{ _players :: [Player],
_minBuyInChips :: Chips,
_maxBuyInChips :: Chips,
_maxPlayers :: Int,
_board :: [Card],
_winners :: Winners,
_waitlist :: [PlayerName],
_deck :: Deck,
_smallBlind :: Int,
_bigBlind :: Int,
_street :: Street,
_pot :: Chips,
_maxBet :: Chips,
_dealer :: Int,
_currentPosToAct :: Maybe Int -- If Nothing and not PreDeal stage of game then this signifies that
-- no player can act (i.e everyone all in) or
-- if during PreDeal (blinds stage) any player can act first in order to get the game started
-- TODO refactor this logic into ADT such as Nobody | Anyone | Someone PlayerName PlayerPos
}
deriving (Eq, Read, Ord, Generic, ToJSON, FromJSON)
instance Show Game where
show Game {..} =
"\n dealer: "
<> show _dealer
<> "\n _currentPosToAct: "
<> show _currentPosToAct
<> "\n _smallBlind: "
<> show _smallBlind
<> "\n _big_blind: "
<> show _bigBlind
<> "\n _minBuyin: "
<> show _minBuyInChips
<> "\n _maxBuyin: "
<> show _maxBuyInChips
<> "\n _pot: "
<> show _pot
<> "\n _maxBet: "
<> show _maxBet
<> "\n _street: "
<> show _street
<> "\n _winners: "
<> show _winners
<> "\n _board: "
<> show _board
<> "\n _players: "
<> show _players
type PlayerName = Text
data PlayerAction = PlayerAction
{ name :: PlayerName,
action :: Action
}
deriving (Show, Eq, Read, Generic, ToJSON, FromJSON)
-- If you can check, that is you aren't facing an amount you have to call,
-- then when you put in chips it is called a bet. If you have to put in
-- some amount of chips to continue with the hand, and you want to
-- increase the pot, it's called a raise. If it is confusing, just remember
-- this old poker adage: "You can't raise yourself."
--
-- Mucking hands refers to a player choosing not to
-- show his hands after everyone has folded to them. Essentially in
-- this scenario mucking or showing refers to the decision to
-- show ones hand or not to the table after everyone else has folded.
data Action
= SitDown Player -- doesnt progress the game
| LeaveSeat' -- doesnt progress the game
| PostBlind Blind
| Fold
| Call
| Raise Chips
| Check
| Bet Chips
| ShowHand
| MuckHand
| SitOut
| SitIn
| Timeout
deriving (Show, Ord, Eq, Read, Generic, ToJSON, FromJSON)
data GameErr
= NotEnoughChips PlayerName
| OverMaxChipsBuyIn PlayerName
| PlayerNotAtTable PlayerName
| AlreadySatAtTable PlayerName
| NotAtTable PlayerName
| CannotSitAtFullTable PlayerName
| AlreadyOnWaitlist PlayerName
| InvalidMove
PlayerName
InvalidMoveErr
deriving (Show, Eq, Read, Ord, Generic, ToJSON, FromJSON)
-- ToDO -- ONLY ONE ERR MSG FOR EACH POSSIBLE ACTION
--
-- additional text field for more detailed info
--
-- i.e cannotBet "Cannot Bet Should Raise Instead - bets can only be made if there have been zero bets this street"
data InvalidMoveErr
= BlindNotRequired
| BlindRequiredErr Blind
| NoBlindRequiredErr
| BlindAlreadyPosted Blind
| OutOfTurn CurrentPlayerToActErr -- _currentPosToAct is Just but not the player's index
| NoPlayerCanAct -- _currentPosToAct is Nothing
| CannotPostBlindOutsidePreDeal
| CannotPostNoBlind -- if player tries to apply postBlind with a value of NoBlind
| CannotPostBlind Text
| InvalidActionForStreet
| BetLessThanBigBlind
| NotEnoughChipsForAction
| CannotBetShouldRaiseInstead Text
| PlayerToActNotAtTable
| CannotRaiseShouldBetInstead
| RaiseAmountBelowMinRaise Int
| CannotCheckShouldCallRaiseOrFold
| CannotCallZeroAmountCheckOrBetInstead
| CannotShowHandOrMuckHand Text
| CannotLeaveSeatOutsidePreDeal
| CannotSitDownOutsidePreDeal
| CannotSitInOutsidePreDeal
| AlreadySatIn
| AlreadySatOut -- cannot sitout when already satout
| CannotSitOutOutsidePreDeal
deriving (Show, Eq, Read, Ord, Generic, ToJSON, FromJSON)
newtype CurrentPlayerToActErr
= CurrentPlayerToActErr PlayerName
deriving (Show, Eq, Read, Ord, Generic, ToJSON, FromJSON)
makeLenses ''Player
makeLenses ''PlayerAction
makeLenses ''Game
makeLenses ''Winners
-- Due to the GHC Stage Restriction, the call to the Template Haskell function derivePersistField must be
-- in a separate module than where the generated code is used.
-- Perform marshaling using the Show and Read
-- instances of the datatype to string field in db
derivePersistField "Player"
derivePersistField "Winners"
derivePersistField "HandRank"
derivePersistField "Street"
derivePersistField "Card"
================================================
FILE: server/src/Schema.hs
================================================
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Schema where
import Control.Monad ()
import Data.Aeson ()
import Data.Aeson.Types ()
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Database.Persist.TH
( mkMigrate,
mkPersist,
persistLowerCase,
share,
sqlSettings,
)
import Poker.Types
( Bet,
Card,
Player,
PlayerName,
Street,
Winners,
)
share
[mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase|
UserEntity json sql=users
username Text
email Text
password Text
availableChips Int
chipsInPlay Int
createdAt UTCTime default=now()
UniqueEmail email
UniqueUsername username
deriving Show Read
TableEntity json sql=tables
name Text
UniqueName name
deriving Show Read
GameEntity json sql=games
tableID TableEntityId
createdAt UTCTime default=now()
players [Player]
minBuyInChips Int
maxBuyInChips Int
maxPlayers Int
board [Card]
winners Winners
waitlist [PlayerName]
deck [Card]
smallBlind Int
bigBlind Int
street Street
pot Int
maxBet Bet
dealer Int
currentPosToAct Int Maybe
deriving Show Read
|]
================================================
FILE: server/src/Socket/Auth.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Socket.Auth where
import Control.Monad.Except (runExceptT)
import Crypto.JOSE as Jose (decodeCompact)
import Crypto.JWT
( ClaimsSet,
JWTError,
decodeCompact,
defaultJWTValidationSettings,
verifyClaims,
)
import Crypto.JWT as Jose
( ClaimsSet,
JWTError,
JWTValidationSettings,
decodeCompact,
defaultJWTValidationSettings,
verifyClaims,
)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Either (Either)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Database.Persist.Postgresql
( ConnectionString,
entityVal,
)
import qualified Network.WebSockets as WS
import Servant.Auth.Server
( IsMatch (DoesNotMatch, Matches),
JWTSettings (audienceMatches),
defaultJWTSettings,
fromSecret,
)
import Text.Pretty.Simple (pPrint)
import Prelude
verifyJWT :: BS.ByteString -> BL.ByteString -> IO (Either JWTError ClaimsSet)
verifyJWT key jwt = runExceptT $ do
jwt' <- decodeCompact jwt
-- decode JWT
verifyClaims jwtCfg jwk jwt'
where
jwk = fromSecret key
jwtCfg = jwtSettingsToJwtValidationSettings $ defaultJWTSettings jwk
jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings
jwtSettingsToJwtValidationSettings s =
defaultJWTValidationSettings
(toBool <$> audienceMatches s)
where
toBool Matches = True
toBool DoesNotMatch = False
================================================
FILE: server/src/Socket/Clients.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Socket.Clients where
import Control.Concurrent.Async (async)
import Control.Concurrent.STM
( STM,
TVar,
atomically,
readTVar,
readTVarIO,
swapTVar,
)
import Control.Lens (At (at), (^.))
import Control.Monad (Monad (return), forM_, void)
import Control.Monad.Except (MonadIO (liftIO), runExceptT)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Maybe (Maybe (Just))
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Database.Persist.Postgresql
( ConnectionString,
entityVal,
)
import qualified Network.WebSockets as WS
import Pipes (each, for, runEffect, yield, (>->))
import Pipes.Concurrent (toOutput)
import Pipes.Core (push)
import Poker.Game.Privacy
( excludeOtherPlayerCards,
excludePrivateCards,
)
import Servant.Auth.Server (FromJWT (decodeJWT))
import Socket.Auth (verifyJWT)
import Socket.Types
( Client (..),
Err (AuthFailed),
Lobby (..),
MsgIn,
MsgOut
( NewGameState,
SuccessfullySatDown,
SuccessfullySubscribedToTable
),
ServerState (..),
Table (..),
TableName,
Token (..),
)
import Socket.Utils (encodeMsgToJSON, encodeMsgX)
import Types (RedisConfig, Username (..))
import Prelude
authClient ::
BS.ByteString ->
TVar ServerState ->
ConnectionString ->
RedisConfig ->
WS.Connection ->
Token ->
IO (Either Err Username)
authClient secretKey state dbConn redisConfig conn (Token token) = do
authResult <- runExceptT $ liftIO $ verifyJWT secretKey token'
case authResult of
Left err -> return $ Left $ AuthFailed err
Right (Left err) -> return $ Left $ AuthFailed $ T.pack $ show err
Right (Right claimsSet) -> case decodeJWT claimsSet of
Left jwtErr -> return $ Left $ AuthFailed $ T.pack $ show jwtErr
Right username@(Username name) -> return $ pure $ Username name
where
token' = C.pack $ T.unpack token
removeClient :: Username -> TVar ServerState -> IO ServerState
removeClient username serverStateTVar = do
ServerState {..} <- readTVarIO serverStateTVar
let newClients = M.delete username clients
newState = ServerState {clients = newClients, ..}
atomically $ swapTVar serverStateTVar newState
clientExists :: Username -> Map Username Client -> Bool
clientExists = M.member
insertClient :: Client -> Username -> Map Username Client -> Map Username Client
insertClient client username = M.insert username client
addClient :: TVar ServerState -> Client -> STM ServerState
addClient s c@Client {..} = do
ServerState {..} <- readTVar s
swapTVar
s
( ServerState
{ clients = insertClient c (Username clientUsername) clients,
..
}
)
getClient :: Map Username Client -> Username -> Maybe Client
getClient cs username = cs ^. at username
broadcastAllClients :: Map Username Client -> MsgOut -> IO ()
broadcastAllClients clients msg =
forM_ (M.elems clients) (\Client {..} -> sendMsg conn msg)
broadcastTableSubscribers :: Table -> Map Username Client -> MsgOut -> IO ()
broadcastTableSubscribers Table {..} clients msg =
forM_
subscriberConns
(\Client {..} -> sendMsg conn msg)
where
subscriberConns = clients `M.restrictKeys` Set.fromList subscribers
sendMsgs :: [WS.Connection] -> MsgOut -> IO ()
sendMsgs conns msg = forM_ conns $ \conn -> sendMsg conn msg
sendMsg :: WS.Connection -> MsgOut -> IO ()
sendMsg conn msg = WS.sendTextData conn (encodeMsgToJSON msg)
sendMsgX :: WS.Connection -> MsgIn -> IO ()
sendMsgX conn msg = WS.sendTextData conn (encodeMsgX msg)
getClientConn :: Client -> WS.Connection
getClientConn Client {..} = conn
broadcastMsg :: Map Username Client -> [Username] -> MsgOut -> IO ()
broadcastMsg clients usernames msg =
forM_
conns
(\Client {..} -> sendMsg conn $ filterPrivateGameData clientUsername msg)
where
conns = clients `M.restrictKeys` Set.fromList usernames
-- Filter out private data such as other players cards which is not
-- intended for the client.
filterPrivateGameData :: Text -> MsgOut -> MsgOut
filterPrivateGameData username (SuccessfullySatDown tableName game) =
SuccessfullySatDown tableName (excludeOtherPlayerCards username game)
filterPrivateGameData username (SuccessfullySubscribedToTable tableName game) =
SuccessfullySubscribedToTable
tableName
(excludePrivateCards (Just username) game)
filterPrivateGameData username (NewGameState tableName game) =
NewGameState tableName (excludeOtherPlayerCards username game)
filterPrivateGameData _ unfilteredMsg = unfilteredMsg
getTablesUserSubscribedTo :: Client -> Lobby -> [(TableName, Table)]
getTablesUserSubscribedTo Client {..} (Lobby lobby) =
filter
(subscriberIncludesClient . snd)
(M.toList lobby)
where
subscriberIncludesClient Table {..} =
Username clientUsername `elem` subscribers
tablesToMsgs :: Text -> [(TableName, Table)] -> [MsgOut]
tablesToMsgs clientUsername' = (<$>) toFilteredMsg
where
gameToMsg (tableName, Table {..}) = NewGameState tableName game
toFilteredMsg = filterPrivateGameData clientUsername' . gameToMsg
getSubscribedGameStates :: Client -> Lobby -> [MsgOut]
getSubscribedGameStates c@Client {..} l =
tablesToMsgs clientUsername $ getTablesUserSubscribedTo c l
-- Used so that reconnected users can get up to speed on games when they regain connection
-- after a disconnect.
updateWithLatestGames :: Client -> Lobby -> IO ()
updateWithLatestGames client@Client {..} lobby =
void $
async $
runEffect $
for
(each latestGameStates)
(\msg -> yield msg >-> toOutput outgoingMailbox)
where
latestGameStates = getSubscribedGameStates client lobby
================================================
FILE: server/src/Socket/Lobby.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Socket.Lobby where
import Control.Concurrent
( MVar,
modifyMVar,
modifyMVar_,
readMVar,
)
import Control.Concurrent.STM (atomically, newBroadcastTChan)
import Control.Concurrent.STM.TChan (newBroadcastTChan)
import Control.Lens (At (at), (.~), (?~))
import Control.Lens.At (At (at))
import Control.Monad (void)
import Control.Monad.STM (atomically)
import Data.ByteString.Char8
( pack,
unpack,
)
import Data.Int (Int64)
import Data.List (unfoldr)
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Text (Text)
import Pipes.Concurrent (atomically, newest, spawn)
import Poker.Game.Utils (shuffledDeck)
import Poker.Poker (initPlayer, initialGameState)
import Poker.Types (Game (..), unChips)
import Socket.Types
( Lobby (..),
Table (..),
TableName,
TableSummary (..),
headsUpBotsConfig,
)
import Socket.Utils (unLobby)
import System.Random (getStdGen)
import Types (Username (..))
initialLobby :: IO Lobby
initialLobby = do
chan <- atomically newBroadcastTChan
randGen <- getStdGen
let shuffledDeck' = shuffledDeck randGen
(output, input) <- spawn $ newest 1
let tableName = "Black"
let table' =
Table
{ subscribers = [],
gameInMailbox = output,
gameOutMailbox = input,
waitlist = [],
game = initialGameState shuffledDeck',
channel = chan,
config = headsUpBotsConfig
}
return $ Lobby $ M.fromList [("Black", table')]
joinGame :: Username -> Int -> Game -> Game
joinGame (Username username) chips Game {..} =
Game {_players = _players <> pure player, ..}
where
player = initPlayer username chips
joinTableWaitlist :: Username -> Table -> Table
joinTableWaitlist username Table {..} =
Table {waitlist = waitlist <> [username], ..}
insertTable :: TableName -> Table -> Lobby -> Lobby
insertTable tableName newTable = Lobby . (at tableName ?~ newTable) . unLobby
canJoinGame :: Game -> Bool
canJoinGame Game {..} = length _players < _maxPlayers
summariseGame :: TableName -> Table -> TableSummary
summariseGame tableName Table {game = Game {..}, ..} =
TableSummary
{ _tableName = tableName,
_playerCount = length _players,
_waitlistCount = length _waitlist,
_minBuyInChips = unChips _minBuyInChips,
_maxBuyInChips = unChips _maxBuyInChips,
..
}
summariseTables :: Lobby -> [TableSummary]
summariseTables (Lobby lobby) = uncurry summariseGame <$> M.toList lobby
================================================
FILE: server/src/Socket/Msg.hs
================================================
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module Socket.Msg where
import Control.Applicative (Applicative ((<*)), (<$>))
import Control.Concurrent.STM (atomically, readTVarIO)
import Control.Monad (Monad (return))
import Control.Monad.Except (Monad (return), MonadIO (liftIO))
import Control.Monad.Reader
( Monad (return),
MonadIO (liftIO),
MonadReader (ask),
ReaderT,
)
import Control.Monad.STM (atomically)
import Control.Monad.State.Lazy (Monad (return), MonadIO (liftIO))
import Data.Either (Either (..), either)
import Data.Foldable (find, notElem)
import Data.Functor ((<$>))
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Maybe (Maybe (Just, Nothing))
import Data.Text (Text)
import qualified Data.Text as T
import Database
( dbDepositChipsIntoPlay,
dbGetUserByUsername,
dbWithdrawChipsFromPlay,
)
import Database.Persist.Postgresql (ConnectionString)
import qualified Network.WebSockets as WS
import Poker.Game.Game (initPlayer)
import Poker.Game.Utils (getGamePlayerNames)
import Poker.Poker (initPlayer, runPlayerAction)
import Poker.Types
import Schema
( UserEntity
( UserEntity,
userEntityAvailableChips,
userEntityChipsInPlay,
userEntityCreatedAt,
userEntityEmail,
userEntityPassword,
userEntityUsername
),
)
import Socket.Clients (sendMsg)
import Socket.Lobby (summariseTables)
import Socket.Subscriptions (subscribeToTableHandler)
import Socket.Table (getTable, updateTable')
import Socket.Types
( Err
( ChipAmountNotWithinBuyInRange,
GameErr,
NotEnoughChipsToSit,
NotSatInGame,
TableDoesNotExist,
UserDoesNotExistInDB
),
GameMsgIn (..),
MsgHandlerConfig (..),
MsgIn (GameMsgIn, GetTables, SubscribeToTable),
MsgOut (NewGameState, SuccessfullySatDown, TableList),
ServerState (ServerState, clients, lobby),
Table (..),
TableName,
)
import Socket.Utils (unLobby)
import Text.Pretty.Simple (pPrint)
import Types (unUsername)
import Prelude
msgHandler :: MsgIn -> ReaderT MsgHandlerConfig IO (Either Err MsgOut)
msgHandler GetTables {} = getTablesHandler
msgHandler msg@SubscribeToTable {} = subscribeToTableHandler msg
msgHandler (GameMsgIn msg) = gameMsgHandler msg
gameMsgHandler :: GameMsgIn -> ReaderT MsgHandlerConfig IO (Either Err MsgOut)
gameMsgHandler msg@TakeSeat {} = takeSeatHandler msg
gameMsgHandler msg@LeaveSeat {} = leaveSeatHandler msg
gameMsgHandler m@(GameMove tableName action) = do
conf@MsgHandlerConfig {..} <- ask
let playerAction = PlayerAction {name = unUsername username, ..}
moveResult <- liftIO $ playMove conf tableName playerAction
return $ NewGameState tableName <$> moveResult
playMove ::
MsgHandlerConfig -> TableName -> PlayerAction -> IO (Either Err Game)
playMove conf@MsgHandlerConfig {..} tableName playerAction = do
maybeTable <- liftIO $ atomically $ getTable serverStateTVar tableName
case maybeTable of
Nothing -> return $ Left $ TableDoesNotExist tableName
Just Table {..} ->
return $ either (Left . GameErr) Right $ runPlayerAction game playerAction
getTablesHandler :: ReaderT MsgHandlerConfig IO (Either Err MsgOut)
getTablesHandler = do
MsgHandlerConfig {..} <- ask
ServerState {..} <- liftIO $ readTVarIO serverStateTVar
let tableSummaries = TableList $ summariseTables lobby
liftIO $ print tableSummaries
liftIO $ sendMsg clientConn tableSummaries
return $ Right tableSummaries
-- We fork a new thread for each game joined to receive game updates and propagate them to the client
-- We link the new thread to the current thread so on any exception in either then both threads are
-- killed to prevent memory leaks.
--
---- If game is in predeal stage then add player to game else add to waitlist
-- the waitlist is a queue awaiting the next predeal stage of the game
takeSeatHandler :: GameMsgIn -> ReaderT MsgHandlerConfig IO (Either Err MsgOut)
takeSeatHandler (TakeSeat tableName chipsToSit) = do
conf@MsgHandlerConfig {..} <- ask
ServerState {..} <- liftIO $ readTVarIO serverStateTVar
case M.lookup tableName $ unLobby lobby of
Nothing -> return $ Left $ TableDoesNotExist tableName
Just table@Table {..} -> do
canSit <- canTakeSeat chipsToSit tableName table
case canSit of
Left err -> return $ Left err
Right () -> do
let player = initPlayer (unUsername username) chipsToSit
playerAction =
PlayerAction
{ name = unUsername username,
action = SitDown player
}
takeSeatAction = GameMove tableName (SitDown player)
case runPlayerAction
game
PlayerAction
{ name = unUsername username,
action = SitDown player
} of
Left gameErr -> return $ Left $ GameErr gameErr
Right newGame -> do
liftIO $ postTakeSeat conf tableName chipsToSit
liftIO $
sendMsg clientConn (SuccessfullySatDown tableName newGame)
let msgOut = NewGameState tableName newGame
liftIO $
atomically $
updateTable'
serverStateTVar
tableName
newGame
return $ Right msgOut
postTakeSeat :: MsgHandlerConfig -> TableName -> Int -> IO ()
postTakeSeat conf@MsgHandlerConfig {..} name chipsSatWith =
dbDepositChipsIntoPlay dbConn (unUsername username) chipsSatWith
leaveSeatHandler :: GameMsgIn -> ReaderT MsgHandlerConfig IO (Either Err MsgOut)
leaveSeatHandler leaveSeatMove@(LeaveSeat tableName) = do
msgHandlerConfig@MsgHandlerConfig {..} <- ask
ServerState {..} <- liftIO $ readTVarIO serverStateTVar
case M.lookup tableName $ unLobby lobby of
Nothing -> return $ Left $ TableDoesNotExist tableName
Just table@Table {..} ->
if unUsername username `notElem` getGamePlayerNames game
then return $ Left $ NotSatInGame tableName
else do
let eitherProgressedGame =
runPlayerAction
game
PlayerAction {name = unUsername username, action = LeaveSeat'}
case eitherProgressedGame of
Left gameErr -> return $ Left $ GameErr gameErr
Right newGame -> do
let maybePlayer =
find
(\Player {..} -> unUsername username == _playerName)
(_players game)
case maybePlayer of
Nothing -> return $ Left $ NotSatInGame tableName
Just Player {_chips = chipsInPlay, ..} -> do
liftIO $
dbWithdrawChipsFromPlay
dbConn
(unUsername username)
(unChips chipsInPlay)
let msgOut = NewGameState tableName newGame
liftIO $
atomically $
updateTable'
serverStateTVar
tableName
newGame
return $ Right msgOut
canTakeSeat ::
Int -> Text -> Table -> ReaderT MsgHandlerConfig IO (Either Err ())
canTakeSeat chipsToSit tableName Table {game = Game {..}, ..}
| Chips chipsToSit >= _minBuyInChips && Chips chipsToSit <= _maxBuyInChips = do
availableChipsE <- getPlayersAvailableChips
MsgHandlerConfig {..} <- ask
case availableChipsE of
Left err -> return $ Left err
Right chips -> do
tableE <- liftIO $ checkTableExists serverStateTVar tableName
return $ tableE <* hasEnoughChips chips chipsToSit
| otherwise = return $ Left $ ChipAmountNotWithinBuyInRange tableName
where
hasEnoughChips availableChips chipsNeeded =
if availableChips >= chipsToSit
then return $ Right ()
else return $ Left NotEnoughChipsToSit
checkTableExists s name = do
t <- atomically $ getTable s name
case t of
Nothing -> return $ Left $ TableDoesNotExist name
_ -> return $ Right ()
getPlayersAvailableChips :: ReaderT MsgHandlerConfig IO (Either Err Int)
getPlayersAvailableChips = do
MsgHandlerConfig {..} <- ask
maybeUser <- liftIO $ dbGetUserByUsername dbConn username
return $ case maybeUser of
Nothing -> Left $ UserDoesNotExistInDB (unUsername username)
Just UserEntity {..} ->
Right $ userEntityAvailableChips - userEntityChipsInPlay
================================================
FILE: server/src/Socket/Setup.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Socket.Setup where
import Control.Concurrent.Async (Async)
import Control.Monad (void)
import Control.Monad.Except (void)
import Control.Monad.Reader (runReaderT)
import Data.ByteString.Char8
( pack,
unpack,
)
import Data.Int (Int64)
import Data.List (unfoldr)
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Text (Text)
import Database (runRedisAction)
import Database.Persist.Postgresql (ConnectionString)
import Database.Redis
( Redis,
connect,
runRedis,
setex,
)
import qualified Database.Redis as Redis
import Socket.Lobby (initialLobby)
import Types (RedisConfig)
-- lobby including all game state is stored in redis
setInitialLobby :: RedisConfig -> IO ()
setInitialLobby redisConfig = do
lobby <- initialLobby
runRedisAction redisConfig $
void $
Redis.hsetnx
"gamesState"
"lobby"
(pack $ show lobby)
intialiseGameStateInRedis :: RedisConfig -> IO ()
intialiseGameStateInRedis = setInitialLobby
================================================
FILE: server/src/Socket/Subscriptions.hs
================================================
{-
Logic for updating players about table changes
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Socket.Subscriptions where
import Control.Concurrent.STM
( STM,
atomically,
readTVar,
readTVarIO,
swapTVar,
throwSTM,
)
import Control.Monad (Monad (return))
import Control.Monad.Except (Monad (return), MonadIO (liftIO))
import Control.Monad.Reader
( Monad (return),
MonadIO (liftIO),
MonadReader (ask),
ReaderT,
)
import Control.Monad.STM (STM, atomically, throwSTM)
import Control.Monad.State.Lazy (Monad (return), MonadIO (liftIO))
import Data.Either (Either (..))
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Maybe (Maybe (Just, Nothing))
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Network.WebSockets as WS
import Poker.Game.Privacy (excludePrivateCards)
import Socket.Clients (sendMsg)
import Socket.Lobby (insertTable)
import Socket.Types
( CannotAddAlreadySubscribed (CannotAddAlreadySubscribed),
Err (TableDoesNotExist),
Lobby (..),
MsgHandlerConfig (..),
MsgIn (SubscribeToTable),
MsgOut (SuccessfullySubscribedToTable),
ServerState (ServerState, clients, lobby),
Table (..),
TableDoesNotExistInLobby (TableDoesNotExistInLobby),
TableName,
)
import Socket.Utils (unLobby)
import Text.Pretty.Simple (pPrint)
import Types (Username, unUsername)
import Prelude
getTableSubscribers :: TableName -> Lobby -> [Username]
getTableSubscribers tableName (Lobby lobby) = case M.lookup tableName lobby of
Nothing -> []
Just Table {..} -> subscribers
-- First we check the table exists and if the user is not already subscribed then we add them to the list of subscribers
-- Game and any other table updates will be propagated to those on the subscriber list
subscribeToTableHandler ::
MsgIn -> ReaderT MsgHandlerConfig IO (Either Err MsgOut)
subscribeToTableHandler (SubscribeToTable tableName) = do
msgHandlerConfig@MsgHandlerConfig {..} <- ask
ServerState {..} <- liftIO $ readTVarIO serverStateTVar
case M.lookup tableName $ unLobby lobby of
Nothing -> return $ Left $ TableDoesNotExist tableName
Just Table {..} -> do
let privatisedGame = excludePrivateCards (Just (unUsername username)) game
msg' = SuccessfullySubscribedToTable tableName privatisedGame
if username `notElem` subscribers
then do
liftIO $ atomically $ subscribeToTable tableName msgHandlerConfig
liftIO $ sendMsg clientConn msg'
return $ Right msg'
else do
return $ Right msg'
subscribeToTable :: TableName -> MsgHandlerConfig -> STM ()
subscribeToTable tableName MsgHandlerConfig {..} = do
ServerState {..} <- readTVar serverStateTVar
let maybeTable = M.lookup tableName $ unLobby lobby
case maybeTable of
Nothing -> throwSTM $ TableDoesNotExistInLobby tableName
Just table@Table {..} ->
if username `notElem` subscribers
then do
let updatedTable =
Table {subscribers = subscribers <> [username], ..}
let updatedLobby = insertTable tableName updatedTable lobby
let newServerState = ServerState {lobby = updatedLobby, ..}
swapTVar serverStateTVar newServerState
return ()
else throwSTM $ CannotAddAlreadySubscribed tableName
================================================
FILE: server/src/Socket/Table.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Socket.Table where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (Async, async)
import Control.Concurrent.STM
( STM,
TVar,
atomically,
readTVar,
readTVarIO,
swapTVar,
throwSTM,
)
import Control.Lens ((^.))
import Control.Monad
( Monad (return),
forM_,
forever,
mapM_,
unless,
void,
when,
)
import Control.Monad.Except
( Monad (return),
MonadIO (liftIO),
forM_,
forever,
mapM_,
when,
)
import Control.Monad.Reader
( Monad (return),
MonadIO (liftIO),
forM_,
forever,
mapM_,
when,
)
import qualified Data.ByteString.Lazy.Char8 as C
import Data.ByteString.UTF8 (fromString)
import Data.Either (Either (Left, Right), isRight)
import qualified Data.Map.Lazy as M
import Data.Maybe (Maybe (..), fromMaybe)
import Data.Text as T (Text, pack)
import Database (dbGetTableEntity, dbInsertGame)
import Database.Persist (Entity (Entity), PersistEntity (Key))
import Database.Persist.Postgresql
( ConnectionString,
SqlPersistT,
runMigration,
withPostgresqlConn,
)
import qualified Network.WebSockets as WS
import Pipes
( Consumer,
Effect,
Pipe,
await,
runEffect,
yield,
(>->),
)
import Pipes.Concurrent
( Input,
Output,
STM,
atomically,
fromInput,
readTVar,
toOutput,
)
import Pipes.Core (push)
import Pipes.Parse (yield)
import qualified Pipes.Prelude as P
import Poker.ActionValidation (validateAction)
import Poker.Game.Game (doesPlayerHaveToAct, initPlayer)
import Poker.Game.Privacy (excludeOtherPlayerCards)
import Poker.Game.Utils
import Poker.Poker
( canProgressGame,
progressGame,
runPlayerAction,
)
import Poker.Types
import Schema (Key, TableEntity)
import Socket.Types
( Client (..),
Lobby (..),
MsgOut (NewGameState),
ServerState (..),
Table (..),
TableConfig (..),
TableDoesNotExistInLobby (TableDoesNotExistInLobby),
TableName,
)
import Socket.Utils (unLobby)
import System.Random
import Types ()
import Prelude
setUpTablePipes ::
ConnectionString -> TVar ServerState -> TableName -> Table -> IO (Async ())
setUpTablePipes connStr s name Table {..} = do
t <- dbGetTableEntity connStr name
let (Entity key _) = fromMaybe notFoundErr t
async $
forever $
runEffect $
gamePipeline
connStr
s
key
name
gameOutMailbox
gameInMailbox
where
--threadDelay (7 * 1000000) -- delay so can see whats going on
-- botPipes botNames = mapM_ (runBot gameInMailbox gameOutMailbox) botNames
notFoundErr = error $ "Table " <> show name <> " doesn't exist in DB"
getValidBotActions :: Game -> PlayerName -> IO [Action]
getValidBotActions g@Game {..} name = do
betAmount' <- randomRIO (lowerBetBound, chipCount)
let possibleActions = actions _street betAmount'
actionsValidated = validateAction g name <$> possibleActions
pNameActionPairs = zip possibleActions actionsValidated
return $ (<$>) fst $ filter (isRight . snd) pNameActionPairs
where
actions :: Street -> Chips -> [Action]
actions st chips
| st == PreDeal = [PostBlind BigBlind, PostBlind SmallBlind, SitDown (initPlayer name 1500)]
| otherwise = [Check, Call, Fold, Bet chips, Raise chips]
lowerBetBound = if _maxBet > 0 then 2 * _maxBet else Chips _bigBlind
chipCount = maybe 0 (^. chips) (getGamePlayer g name)
-- this is the pipeline of effects we run everytime a new game state
-- is placed in the tables
-- incoming mailbox for new game states.
--
-- New game states are send to the table's incoming mailbox every time a player acts
-- in a way that follows the game rules
--
-- Delays with "pause" at the end of each game stage (Flop, River etc) for UX
-- are done client side.
gamePipeline ::
ConnectionString ->
TVar ServerState ->
Key TableEntity ->
TableName ->
Input Game ->
Output Game ->
Effect IO ()
gamePipeline connStr s key tableName outMailbox inMailbox = do
fromInput outMailbox -- game actions go in this input sink from websocket connections
>-> broadcast s tableName
>-> logGame tableName
>-> updateTable s tableName
>-> writeGameToDB connStr key
>-> nextStagePause
>-> timePlayer s tableName
>-> progress inMailbox -- new gamestates go in this output source
-- TODO should group as manny effect in stm monad not IO -- perhaps
-- Delay to enhance UX based on game stages
timePlayer :: TVar ServerState -> TableName -> Pipe Game Game IO ()
timePlayer s tableName = do
g@Game {..} <- await
let currPlyrToAct = (!!) (getGamePlayerNames g) <$> _currentPosToAct
liftIO $ forM_ currPlyrToAct $ runPlayerTimer s tableName g
yield g
-- 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 (3 * 10000000) -- 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 to enhance UX so game doesn't move through stages
-- instantly when no players can act i.e everyone all in.
nextStagePause :: Pipe Game Game IO ()
nextStagePause = do
g <- await
when (canProgressGame g) $ liftIO $ threadDelay $ pauseDuration g
yield g
where
pauseDuration :: Game -> Int
pauseDuration g@Game {..}
| _street == PreDeal = 0
| _street == Showdown =
5 * 1000000
|
playersNotAllIn _players <= 1 =
5 * 1000000 -- everyone all in
| otherwise = 2 * 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 :: Output Game -> Consumer Game IO ()
progress gameInMailbox = do
g <- await
when (canProgressGame g) (progress' g)
where
progress' game = do
gen <- liftIO getStdGen
liftIO $ setStdGen $ snd $ next gen
runEffect $ yield (progressGame gen game) >-> toOutput gameInMailbox
writeGameToDB :: ConnectionString -> Key TableEntity -> Pipe Game Game IO ()
writeGameToDB connStr tableKey = do
g <- await
_ <- liftIO $ async $ dbInsertGame connStr tableKey g
yield g
-- 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
informSubscriber :: TableName -> Game -> Client -> IO ()
informSubscriber n g Client {..} = do
let filteredGame = excludeOtherPlayerCards clientUsername g
runEffect $ yield (NewGameState n filteredGame) >-> toOutput outgoingMailbox
return ()
-- sends new game states to subscribers
-- At the moment all clients receive updates from every game indiscriminately
broadcast :: TVar ServerState -> TableName -> Pipe Game Game IO ()
broadcast s n = do
g <- await
ServerState {..} <- liftIO $ readTVarIO s
let usernames' = M.keys clients -- usernames to broadcast to
liftIO $ async $ mapM_ (informSubscriber n g) clients
yield g
logGame :: TableName -> Pipe Game Game IO ()
logGame tableName = do
g <- await
liftIO $ print g
yield g
-- 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 :: TVar ServerState -> TableName -> Pipe Game Game IO ()
updateTable serverStateTVar tableName = do
g <- await
liftIO $ atomically $ updateTable' serverStateTVar tableName g
yield g
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, ..}
================================================
FILE: server/src/Socket/Types.hs
================================================
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Socket.Types where
import Control.Concurrent (MVar)
import Control.Concurrent.STM (TChan, TVar)
import Control.Concurrent.STM.TChan (TChan)
import Control.Exception (Exception)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.Types (FromJSON, ToJSON)
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Text (Text)
import Database.Persist.Postgresql (ConnectionString)
import GHC.Generics (Generic)
import qualified Network.WebSockets as WS
import Pipes.Concurrent (Input, Output)
import Pipes
( Consumer,
Effect,
Pipe,
await,
runEffect,
yield,
(>->),
)
import Poker.Types
( Action,
Game,
GameErr,
)
import Types
( RedisConfig,
Username,
)
data MsgHandlerConfig = MsgHandlerConfig
{ dbConn :: ConnectionString,
serverStateTVar :: TVar ServerState,
username :: Username,
clientConn :: WS.Connection,
redisConfig :: RedisConfig
}
type TableName = Text
newtype Lobby
= Lobby (Map TableName Table)
deriving (Ord, Eq, Show)
instance Show ServerState where
show _ = ""
-- exception when adding subscriber to table if subscriber already exists inside STM transaction
newtype CannotAddAlreadySubscribed
= CannotAddAlreadySubscribed Text
deriving (Show)
instance Exception CannotAddAlreadySubscribed
-- exception for cannot find a table with given TableName in Lobby inside STM transaction
newtype TableDoesNotExistInLobby
= TableDoesNotExistInLobby Text
deriving (Show)
instance Exception TableDoesNotExistInLobby
data TableConfig = TableConfig
{ botCount :: Int, -- number of bots to maintain at table
minHumans :: Int -- number of humans to wait for before starting a game
} deriving (Show, Eq, Generic, FromJSON, ToJSON)
headsUpBotsConfig :: TableConfig
headsUpBotsConfig =
TableConfig
{ botCount = 2,
minHumans = 0
}
data Table = Table
{ subscribers :: [Username], -- observing public game state includes players sat down
gameOutMailbox :: Input Game, -- outgoing MsgOuts broadcasts -> write source for msgs to propagate new game states to clients
gameInMailbox :: Output Game, --incoming gamestates -> read (consume) source for new game states
waitlist :: [Username], -- waiting to join a full table
bots :: Maybe (Consumer Game IO ()),
game :: Game,
channel :: TChan MsgOut,
config :: TableConfig
}
instance Show Table where
show Table {..} =
show subscribers <> "\n" <> show waitlist <> "\n" <> show game
instance Eq Table where
Table {game = game1} == Table {game = game2} = game1 == game2
instance Ord Table where
Table {game = game1} `compare` Table {game = game2} =
game1 `compare` game2
data Client = Client
{ clientUsername :: Text,
conn :: WS.Connection,
outgoingMailbox :: Output MsgOut
}
instance Show Client where
show Client {..} = show clientUsername
data ServerState = ServerState
{ clients :: Map Username Client,
lobby :: Lobby
}
instance Eq Client where
Client {clientUsername = clientUsername1} == Client {clientUsername = clientUsername2} =
clientUsername1 == clientUsername2
-- incoming messages from a ws client
data MsgIn
= GetTables
| SubscribeToTable TableName
| LeaveTable
| GameMsgIn GameMsgIn
deriving (Show, Eq, Generic, FromJSON, ToJSON)
data GameMsgIn
= TakeSeat
TableName
Int
| LeaveSeat TableName
| GameMove TableName Action
deriving (Show, Eq, Generic, FromJSON, ToJSON)
-- For the lobby view so client can make an informed decision about which game to join
data TableSummary = TableSummary
{ _tableName :: Text,
_playerCount :: Int,
_minBuyInChips :: Int,
_maxBuyInChips :: Int,
_maxPlayers :: Int,
_waitlistCount :: Int,
_smallBlind :: Int,
_bigBlind :: Int
}
deriving (Show, Eq, Generic, FromJSON, ToJSON)
-- outgoing messages for clients
data MsgOut
= TableList [TableSummary]
| SuccessfullySatDown
TableName
Game
| SuccessfullyLeftSeat TableName
| SuccessfullySubscribedToTable
TableName
Game
| GameMsgOut GameMsgOut
| NewGameState TableName Game
| ErrMsg Err
| AuthSuccess
| Noop
deriving (Show, Eq, Generic, FromJSON, ToJSON)
data GameMsgOut
= GameMoveErr Err
| PlayerLeft
| PlayerJoined TableName Text
deriving (Show, Eq, Generic, FromJSON, ToJSON)
data Err
= TableFull TableName
| TableDoesNotExist TableName
| NotSatAtTable TableName
| AlreadySatInGame TableName
| NotSatInGame TableName
| AlreadySatAtTable TableName
| AlreadySubscribedToTable TableName
| NotEnoughChipsToSit
| GameErr GameErr
| InvalidGameAction
| ChipAmountNotWithinBuyInRange TableName
| UserDoesNotExistInDB Text
| AuthFailed Text
deriving (Show, Eq, Generic, FromJSON, ToJSON)
newtype Token = Token Text -- JWT
================================================
FILE: server/src/Socket/Utils.hs
================================================
module Socket.Utils where
import Data.Aeson (decode, encode)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as X
import qualified Data.Text.Lazy.Encoding as D
import Data.Time.Calendar (Day (ModifiedJulianDay))
import Data.Time.Clock (UTCTime (UTCTime), secondsToDiffTime)
import Socket.Types (Lobby (..), MsgIn, MsgOut, Table, TableName)
import Text.Pretty.Simple (pPrint)
import Prelude
encodeMsgToJSON :: MsgOut -> Text
encodeMsgToJSON a = T.pack $ show $ X.toStrict $ D.decodeUtf8 $ encode a
encodeMsgX :: MsgIn -> Text
encodeMsgX a = T.pack $ show $ X.toStrict $ D.decodeUtf8 $ encode a
parseMsgFromJSON :: Text -> Maybe MsgIn
parseMsgFromJSON jsonTxt = decode $ C.pack $ T.unpack jsonTxt
parseMsgFromJSON' :: BS.ByteString -> Maybe MsgIn
parseMsgFromJSON' jsonTxt = decode $ C.fromStrict jsonTxt
getTimestamp :: UTCTime
getTimestamp = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)
unLobby :: Lobby -> Map TableName Table
unLobby (Lobby lobby) = lobby
================================================
FILE: server/src/Socket/Workers.hs
================================================
{-# LANGUAGE RecordWildCards #-}
module Socket.Workers where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (Async, async)
import Control.Concurrent.STM
( TChan,
TVar,
atomically,
dupTChan,
readTChan,
)
import Control.Concurrent.STM.TChan (TChan, dupTChan, readTChan)
import Control.Monad (forever)
import Control.Monad.STM (atomically)
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Text (Text)
import Database
( dbGetTableEntity,
dbInsertTableEntity,
dbRefillAvailableChips,
)
import Database.Persist (Entity (Entity), PersistEntity (Key))
import Database.Persist.Postgresql
( ConnectionString,
SqlPersistT,
runMigration,
withPostgresqlConn,
)
import Schema (Key, TableEntity)
import Socket.Types
( Lobby (..),
MsgOut (NewGameState),
ServerState,
Table
( Table,
channel,
game,
gameInMailbox,
gameOutMailbox,
subscribers,
waitlist
),
TableName,
)
forkBackgroundJobs ::
ConnectionString -> TVar ServerState -> Lobby -> IO [Async ()]
forkBackgroundJobs connString serverStateTVar lobby = do
forkChipRefillDBWriter connString chipRefillInterval chipRefillThreshold -- Periodically refill player chip balances when too low.
forkGameDBWriters connString lobby -- At the end of game write new game and player data to the DB.
where
chipRefillInterval = 50000000 -- 1 mins
chipRefillThreshold = 200000 -- any lower chip count will be topped up on refill to this amount
-- Fork a new thread for each table that writes game updates received from the table channel to the DB
forkGameDBWriters :: ConnectionString -> Lobby -> IO [Async ()]
forkGameDBWriters connString (Lobby lobby) =
sequence $
( \(tableName, Table {..}) -> forkGameDBWriter connString channel tableName
)
<$> M.toList lobby
-- Looks up the tableName in the DB to get the key and if no corresponsing table is found in the db then
-- we insert a new table to the db. This step is necessary as we use the TableID as a foreign key in the
-- For Game Entities in the DB.
-- After we have the TableID we fork a new process which listens to the channel which emits new game states
-- for a given table. For each new game state msg received we write the new game state into the DB.
forkGameDBWriter ::
ConnectionString -> TChan MsgOut -> TableName -> IO (Async ())
forkGameDBWriter connString chan tableName = do
maybeTableEntity <- dbGetTableEntity connString tableName
case maybeTableEntity of
Nothing -> do
tableKey <- dbInsertTableEntity connString tableName
forkGameWriter tableKey
Just (Entity tableKey _) -> forkGameWriter tableKey
where
forkGameWriter tableKey =
async (writeNewGameStatesToDB connString chan tableKey)
writeNewGameStatesToDB ::
ConnectionString -> TChan MsgOut -> Key TableEntity -> IO ()
writeNewGameStatesToDB connString chan tableKey = do
dupChan <- atomically $ dupTChan chan
forever $ do
chanMsg <- atomically $ readTChan dupChan
case chanMsg of
(NewGameState tableName game) -> return ()
_ -> return ()
-- Fork a thread which refills low player chips balances in DB at a given interval
forkChipRefillDBWriter :: ConnectionString -> Int -> Int -> IO (Async ())
forkChipRefillDBWriter connString interval chipsThreshold =
async $
forever $ do
dbRefillAvailableChips connString chipsThreshold
threadDelay interval
================================================
FILE: server/src/Socket.hs
================================================
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Socket
( runSocketServer,
)
where
import Bots
import Bots (bot1, bot2)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.Async (Async, async)
import Control.Concurrent.STM
( STM,
TVar,
atomically,
newTVarIO,
readTVar,
readTVarIO,
writeTVar,
)
import Control.Exception ()
import Control.Lens ((^.))
import Control.Monad (Monad (return), forever, void)
import Control.Monad.Except
( Monad (return),
MonadIO (liftIO),
MonadTrans (lift),
forever,
void,
)
import Control.Monad.Reader
( Monad (return),
MonadIO (liftIO),
MonadTrans (lift),
ReaderT (runReaderT),
forever,
void,
)
import Control.Monad.STM (STM, atomically)
import Crypto.JWT ()
import Data.Aeson
( FromJSON,
ToJSON,
)
import qualified Data.Aeson as A
import qualified Data.ByteString as BS
import Data.ByteString.Lazy
( fromStrict,
toStrict,
)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as C
import Data.ByteString.UTF8 (fromString)
import Data.Either (Either (Left, Right))
import Data.Foldable (traverse_)
import qualified Data.List as L
import qualified Data.Map.Lazy as M
import Data.Maybe (Maybe (Just, Nothing))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as X
import qualified Data.Text.Lazy.Encoding as D
import Database ()
import Database.Persist.Postgresql (ConnectionString)
import qualified GHC.IO.Exception as G
import qualified Network.WebSockets as WS
import Pipes
( MonadIO (liftIO),
MonadTrans (lift),
Pipe,
Producer,
await,
for,
runEffect,
void,
yield,
(>->),
)
import Pipes.Aeson (decode)
import Pipes.Concurrent
( Input,
Output (send),
STM,
atomically,
forkIO,
fromInput,
newTVarIO,
newest,
readTVar,
spawn,
toOutput,
)
import Pipes.Core (push)
import Pipes.Parse
( Producer,
StateT (runStateT),
draw,
lift,
yield,
)
import qualified Pipes.Prelude as P
import Poker.ActionValidation ()
import Poker.Game.Blinds ()
import Poker.Game.Game ()
import Poker.Game.Utils ()
import Poker.Poker ()
import Poker.Types (Game, playerName)
import Socket.Clients
( addClient,
authClient,
sendMsg,
updateWithLatestGames,
)
import Socket.Lobby (initialLobby, summariseTables)
import Socket.Msg (msgHandler)
import Socket.Setup ()
import Socket.Subscriptions ()
import Socket.Table
( setUpTablePipes,
updateTableAndGetMailbox,
updateTableGame,
)
import Socket.Types
( Client (Client, clientUsername, conn, outgoingMailbox),
GameMsgIn (GameMove),
Lobby,
MsgHandlerConfig (..),
MsgIn,
MsgOut (AuthSuccess, ErrMsg, NewGameState, TableList),
ServerState (..),
TableName,
Token (Token),
)
import Socket.Utils (encodeMsgToJSON, unLobby)
import Socket.Workers (forkBackgroundJobs)
import System.Random ()
import System.Timeout ()
import Types (RedisConfig, Username (Username))
import Web.JWT (Secret)
import Prelude
initialServerState :: Lobby -> ServerState
initialServerState lobby = ServerState {clients = M.empty, lobby = lobby}
-- Create the initial lobby holding all game state and then fork a new thread for each table in the lobby
-- to write new game states to the DB
runSocketServer ::
BS.ByteString -> Int -> ConnectionString -> RedisConfig -> IO ()
runSocketServer secretKey port connString redisConfig = do
lobby <- initialLobby
serverStateTVar <- newTVarIO (initialServerState lobby)
-- set up pipelines for broadcasting, progressing and logging new game states
traverse_
(uncurry $ setUpTablePipes connString serverStateTVar)
(M.toList $ unLobby lobby)
-- workers for refilling chips
forkBackgroundJobs connString serverStateTVar lobby
print $ "Socket server listening on " ++ (show port :: String)
_ <-
async $
WS.runServer "0.0.0.0" port $
application
secretKey
connString
redisConfig
serverStateTVar
return ()
where
botNames = (^. playerName) <$> [bot1]
playersToWaitFor = 2
-- subscriptions are handled by combining each subscribers mailbox into one large mailbox
-- where mew MsgOuts with new game states are posted
--
-- The new game state msgs will then propogate to to the subscribers mailbox and
-- sent via their websocket connection automatically
subscribeToTable :: Output MsgOut -> Output MsgOut -> Output MsgOut
subscribeToTable tableOutput playerOutput = tableOutput <> playerOutput
-- Note this doesn't propagate new game state to clients just updates the game in the lobby
updateGame :: TVar ServerState -> TableName -> Game -> STM ()
updateGame s tableName g = do
ServerState {..} <- readTVar s
let newLobby = updateTableGame tableName g lobby
writeTVar s ServerState {lobby = newLobby, ..}
-- creates a mailbox which has both an input sink and output source which
-- models the bidirectionality of websockets.
-- We return input source which emits our received socket msgs.
websocketInMailbox :: MsgHandlerConfig -> IO (Output MsgIn, Output MsgOut)
websocketInMailbox conf@MsgHandlerConfig {..} = do
(writeMsgInSource, readMsgInSource) <- spawn $ newest 1
(writeMsgOutSource, readMsgOutSource) <- spawn $ newest 1
async $
forever $
runEffect $
fromInput readMsgInSource
>-> msgInHandler conf
>-> toOutput writeMsgOutSource -- process received MsgIn's and place resulting MsgOut in outgoing mailbox
async $ socketMsgOutWriter clientConn readMsgOutSource -- send encoded MsgOuts from outgoing mailbox to socket
return (writeMsgInSource, writeMsgOutSource)
-- Runs an IO action forever which parses read MsgIn's from the websocket connection
-- and puts them in our mailbox waiting to be processed by our MsgIn handler
--
-- Note - only parsed MsgIns make it into the mailbox - socket msgs which cannot be parsed
-- are silently ignored but logged anyway.
socketMsgInWriter :: WS.Connection -> Output MsgIn -> IO ()
socketMsgInWriter conn writeMsgInSource = do
_ <-
async $
forever $
runEffect $
msgInDecoder (socketReader conn >-> logMsgIn)
>-> toOutput writeMsgInSource
return ()
socketMsgOutWriter :: WS.Connection -> Input MsgOut -> IO (Async ())
socketMsgOutWriter conn is =
forever $
runEffect $
for
(fromInput is >-> msgOutEncoder)
(lift . WS.sendTextData conn)
-- Converts a websocket connection into a producer
socketReader :: WS.Connection -> Producer BS.ByteString IO ()
socketReader conn = forever $ do
msg <- liftIO $ WS.receiveData conn
yield msg
-- Convert a raw Bytestring producer of raw JSON into a new producer which yields
-- only successfully parsed values of type MsgIn.
--
-- Note that this parser deliberately ignores parsing errors as the naive implementation
-- would lead to parse errors closing the stream pipeline and thus the socket connection
msgInDecoder :: Producer BS.ByteString IO () -> Producer MsgIn IO ()
msgInDecoder rawMsgProducer = do
(x, p') <- lift $ runStateT decode rawMsgProducer
case x of
Nothing -> return ()
Just (Left a) -> do
(_invalidMsg, p'') <- lift $ runStateT draw p'
msgInDecoder p''
Just c@(Right parsedMsgIn) -> do
yield parsedMsgIn
msgInDecoder p'
msgOutEncoder :: Pipe MsgOut Text IO ()
msgOutEncoder = do
msgOut <- await
yield $ encodeMsgToJSON msgOut
-- branches of code which do not yield messages place the burden of informing the client
-- onto the table pipeline as opposed to the remaining components after the player's socket
-- pipeline. Or in other words without yielding a msg this pipe will not directly inform the client
-- about what has happened.
msgInHandler :: MsgHandlerConfig -> Pipe MsgIn MsgOut IO ()
msgInHandler conf@MsgHandlerConfig {..} = do
msgIn <- await
res <- lift $ runReaderT (msgHandler msgIn) conf
case res of
Left err -> yield $ ErrMsg err
Right (NewGameState tableName g) ->
liftIO $ atomically $ updateGameState serverStateTVar tableName g
Right m -> yield m
-- The main function for handling game updates which consists of
-- a series of events whose order must be guaranteed which
-- is why they are grouped in a STM block.
--
-- 1 - We update our game in the server state
-- 2 - We send new game to
-- the table's mailbox for broadcasting to clients and other actions
-- such as progressing the game along if possible
updateGameState :: TVar ServerState -> TableName -> Game -> STM ()
updateGameState serverStateTVar tableName newGame = do
mbGameInMailbox' <- updateTableAndGetMailbox serverStateTVar tableName newGame
case mbGameInMailbox' of
Nothing -> return ()
Just gameInMailbox' -> void (send gameInMailbox' newGame)
logMsgIn :: Pipe BS.ByteString BS.ByteString IO ()
logMsgIn = do
msg <- await
yield msg
logMsgOut :: Pipe MsgOut MsgOut IO ()
logMsgOut = do
msg <- await
yield msg
-- get a pipe which only forwards the game moves which occur at the given table
filterMsgsForTable :: Monad m => TableName -> Pipe GameMsgIn GameMsgIn m ()
filterMsgsForTable tableName =
P.filter $ \(GameMove tableName' _) -> tableName == tableName'
-- New WS connections are expected to supply an access token as an initial msg
-- Once the token is verified the connection only then will the server state be
-- updated with the newly authenticated client.
--
-- After the client has been authenticated we fork a thread which writes
-- the clients msgs to a channel.
application ::
BS.ByteString ->
ConnectionString ->
RedisConfig ->
TVar ServerState ->
WS.ServerApp
application secretKey dbConnString redisConfig s pending = do
conn <- WS.acceptRequest pending
WS.forkPingThread conn 30
authMsg <- WS.receiveData conn
ServerState {..} <- readTVarIO s
eUsername <-
authClient
secretKey
s
dbConnString
redisConfig
conn
(Token authMsg)
case eUsername of
Right u@(Username clientUsername) -> do
(incomingMailbox, outgoingMailbox) <- websocketInMailbox $ msgConf conn u
let client = Client {..}
sendMsg conn AuthSuccess
let isReconnect = client `elem` clients -- if client already on our list of clients then this is a reconnect
updateWithLatestGames client lobby -- Sync game state with reconnected clients
let tableSummaries = TableList $ summariseTables lobby
liftIO $ sendMsg conn tableSummaries
atomically $ addClient s client
ServerState {..} <- liftIO $ atomically $ readTVar s
forever $ do
m <- WS.receiveData conn
runEffect $
msgInDecoder (yield m >-> logMsgIn)
>-> toOutput incomingMailbox
return ()
Left err -> sendMsg conn (ErrMsg err)
where
msgConf c username =
MsgHandlerConfig
{ serverStateTVar = s,
dbConn = dbConnString,
clientConn = c,
redisConfig = redisConfig,
..
}
================================================
FILE: server/src/Types.hs
================================================
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Types where
import Data.Aeson (FromJSON, ToJSON)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Database.Redis (ConnectInfo)
import GHC.Generics (Generic)
import Servant ()
import Servant.API
( Capture,
Get,
JSON,
(:>),
)
import Servant.Auth.Server (FromJWT, ToJWT)
type RedisConfig = ConnectInfo
type Password = Text
data Login = Login
{ loginUsername :: Text,
loginPassword :: Text
}
deriving (Eq, Show, Generic, ToJSON, FromJSON)
data Register = Register
{ newUserEmail :: Text,
newUsername :: Username,
newUserPassword :: Text
}
deriving (Eq, Show, Generic, FromJSON, ToJSON)
newtype Username
= Username Text
deriving (Generic, Show, Read, Eq, Ord, ToJWT, FromJWT)
unUsername :: Username -> Text
unUsername (Username username) = username
instance ToJSON Username
instance FromJSON Username
type UserID = Text
data UserProfile = UserProfile
{ proUsername :: Username,
proEmail :: Text,
proAvailableChips :: Int,
proChipsInPlay :: Int,
proUserCreatedAt :: UTCTime
}
deriving (Eq, Show, Generic, ToJSON, FromJSON)
data ReturnToken = ReturnToken
{ access_token :: Text,
refresh_token :: Text,
expiration :: Int --seconds to expire
}
deriving (Generic, ToJSON, FromJSON)
================================================
FILE: server/src/Users.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Users where
import Control.Monad.Except
( MonadError (throwError),
MonadIO (liftIO),
runExceptT,
)
import qualified Crypto.Hash.SHA256 as H
import qualified Crypto.JOSE as Jose
import Crypto.JWT (JWK)
import qualified Crypto.JWT as Jose
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as CL
import Data.ByteString.Lazy.UTF8 as BLU (toString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Time.Clock (getCurrentTime)
import Database
( dbGetUserByLogin,
dbGetUserByUsername,
dbRegisterUser,
)
import Database.Persist.Postgresql (ConnectionString)
import Schema
( UserEntity
( UserEntity,
userEntityAvailableChips,
userEntityChipsInPlay,
userEntityCreatedAt,
userEntityEmail,
userEntityPassword,
userEntityUsername
),
)
import Servant
( Handler,
NoContent (..),
ServerError (errBody),
err401,
err404,
)
import Servant.Auth.Server (JWTSettings, makeJWT)
import Types
( Login (..),
RedisConfig,
Register (..),
ReturnToken (..),
UserProfile (..),
Username (..),
)
fetchUserProfileHandler :: ConnectionString -> Username -> Handler UserProfile
fetchUserProfileHandler connString username' = do
maybeUser <- liftIO $ dbGetUserByUsername connString username'
case maybeUser of
Nothing -> throwError err404
Just UserEntity {..} ->
return $
UserProfile
{ proEmail = userEntityEmail,
proAvailableChips = userEntityAvailableChips,
proChipsInPlay = userEntityChipsInPlay,
proUsername = Username userEntityUsername,
proUserCreatedAt = userEntityCreatedAt
}
hashPassword :: Text -> Text
hashPassword password = T.pack $ C.unpack $ H.hash $ encodeUtf8 password
signToken :: JWTSettings -> Username -> Handler ReturnToken
signToken jwtSettings username' = do
eToken <- liftIO $ makeJWT username' jwtSettings expiryTime
case eToken of
Left e -> throwError $ unAuthErr $ BS.pack $ show eToken
Right token ->
return $
ReturnToken
{ access_token = T.pack (BLU.toString token),
refresh_token = "",
expiration = 9999999,
..
}
where
expiryTime = Nothing
unAuthErr e = err401 {errBody = e}
loginHandler :: JWTSettings -> ConnectionString -> Login -> Handler ReturnToken
loginHandler jwtSettings connString l@Login {..} = do
liftIO (print l)
maybeUser <- liftIO $ dbGetUserByLogin connString loginWithHashedPswd
case maybeUser of
Nothing -> throwError unAuthErr
Just u@UserEntity {..} ->
signToken jwtSettings (Username userEntityUsername)
where
unAuthErr = err401 {errBody = "Incorrect email or password"}
loginWithHashedPswd =
Login {loginPassword = hashPassword loginPassword, ..}
-- when we register new user we check to see if email and username are already taken
-- if they are then the exception will be propagated to the client
registerUserHandler ::
JWTSettings ->
ConnectionString ->
RedisConfig ->
Register ->
Handler ReturnToken
registerUserHandler jwtSettings connString redisConfig Register {..} = do
currTime <- liftIO getCurrentTime
let hashedPassword = hashPassword newUserPassword
(Username username) = newUsername
newUser =
UserEntity
{ userEntityUsername = username,
userEntityEmail = newUserEmail,
userEntityPassword = hashedPassword,
userEntityAvailableChips = 3000,
userEntityChipsInPlay = 0,
userEntityCreatedAt = currTime
}
registrationResult <-
liftIO $
runExceptT $
dbRegisterUser connString redisConfig newUser
case registrationResult of
Left err -> throwError $ err401 {errBody = CL.pack $ T.unpack err}
_ -> signToken jwtSettings newUsername
getLobbyHandler :: JWTSettings -> ConnectionString -> RedisConfig -> Handler NoContent
getLobbyHandler _ _ _ = do
return NoContent
================================================
FILE: server/stack.yaml
================================================
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-18.13
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# subdirs:
# - auto-update
# - wai
packages:
- .
allow-newer: true
extra-deps:
- servant-options-0.1.0.0
- jwt-0.7.2
- servant-websockets-2.0.0@sha256:6e9e3600bced90fd52ed3d1bf632205cb21479075b20d6637153cc4567000234,2253
- servant-auth-client-0.4.1.0@sha256:96d8153907a00ef05e8918ca03a972d95ecde485da0df12f6532d248f057eb60,3437
- ekg-0.4.0.15@sha256:d6e48859a89fbbe23496f871581e44a41f97dac627c2b9db81f49b92fa066516,2031
- ekg-core-0.1.1.7@sha256:c4356aefea0e1e2f80a236d3b3f81b83b445c1e53519302e96477da0adee2e9f,2039
- ekg-json-0.1.0.6@sha256:e16efc1b09ae7635db3f0535335ee3e8aa666fe4bf3749783f4022020f6ca3b8,1050
nix:
enable: false
pure: false
packages: [ postgresql zlib ]
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
local-bin-path: build
# Dependency packages to be pulled from upstream that are not in the resolver
# using the same syntax as the packages field.
# (e.g., acme-missiles-0.3)
# extra-deps: []
# Override default flag values for local packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.7"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
ghc-options:
"$locals": -j # Parallel Builds
"$locals": -O0 # No GHC optimisations
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor
================================================
FILE: server/test/Poker/ActionSpec.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Poker.ActionSpec where
import Control.Lens (Ixed (ix), (.~), (^.), (^?))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Poker.Game.Actions
( call,
check,
foldCards,
makeBet,
postBlind,
sitOut,
)
import Poker.Game.Utils (initialDeck)
import Poker.Poker (initialGameState)
import Poker.Types
( Blind (SmallBlind),
Game (_pot, _smallBlind),
Player (..),
PlayerState (..),
SatInState (..),
Street (PreDeal, PreFlop),
actedThisTurn,
chips,
committed,
currentPosToAct,
maxBet,
playerStatus,
players,
pot,
street,
)
import Test.Hspec (describe, it, shouldBe)
initialGameState' :: Game
initialGameState' = initialGameState initialDeck
player1 :: Player
player1 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 100,
_actedThisTurn = True,
_possibleActions = []
}
player2 :: Player
player2 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn Folded,
_playerName = "player2",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player3 :: Player
player3 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player3",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player4 :: Player
player4 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player3",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
}
player5 :: Player
player5 =
Player
{ _pockets = Nothing,
_chips = 4000,
_bet = 4000,
_playerStatus = SatIn NotFolded,
_playerName = "player5",
_committed = 4000,
_actedThisTurn = True,
_possibleActions = []
}
player6 :: Player
player6 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 200,
_playerStatus = SatIn NotFolded,
_playerName = "player6",
_committed = 250,
_actedThisTurn = True,
_possibleActions = []
}
bettingFinishedGame :: Game
bettingFinishedGame =
((players .~ [player1, player2]) . (street .~ PreFlop)) initialGameState'
bettingNotFinishedGame :: Game
bettingNotFinishedGame =
((players .~ [player1, player2, player3, player4]) . (street .~ PreFlop))
initialGameState'
spec = do
describe "postBlind" $ do
it "should update player attributes correctly" $ do
let game =
(street .~ PreDeal)
. (players .~ [(committed .~ 0) player1, player3])
$ initialGameState'
pName = "player1"
blind = SmallBlind
newGame = postBlind blind pName game
playerWhoBet = newGame ^? players . ix 0
smallBlindValue = _smallBlind game
expectedPlayer =
Player
{ _pockets = Nothing,
_chips = 2000 - smallBlindValue,
_bet = smallBlindValue,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = smallBlindValue,
_actedThisTurn = True,
_possibleActions = []
}
playerWhoBet `shouldBe` Just expectedPlayer
it "should add blind bet to pot" $ do
let game =
(street .~ PreDeal) . (players .~ [player1, player3]) $
initialGameState'
pName = "player1"
blind = SmallBlind
newGame = postBlind blind pName game
playerWhoBet = newGame ^? players . ix 0
_pot newGame `shouldBe` _smallBlind game
describe "bet" $ do
it "should update player attributes correctly" $ do
let game =
(street .~ PreFlop) . (players .~ [player1, player2, player3]) $
initialGameState'
betValue = 200
pName = "player1"
newGame = makeBet betValue pName game
playerWhoBet = newGame ^? players . ix 0
expectedPlayer =
Player
{ _pockets = Nothing,
_chips = 2000 - betValue,
_bet = betValue,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 100 + betValue,
_actedThisTurn = True,
_possibleActions = []
}
playerWhoBet `shouldBe` Just expectedPlayer
it "should add bet amount to pot" $ do
let game =
(street .~ PreFlop) . (players .~ [player1, player2, player3]) $
initialGameState'
betValue = 200
pName = "player1"
newGame = makeBet betValue pName game
(newGame ^. pot) `shouldBe` betValue
it "should update maxBet if amount greater than current maxBet" $ do
let game =
(street .~ PreFlop) . (players .~ [player1, player2, player3]) $
initialGameState'
betValue = 200
pName = "player1"
newGame = makeBet betValue pName game
(newGame ^. maxBet) `shouldBe` betValue
it "should update player attributes correctly when bet all in" $ do
let game =
(street .~ PreFlop) . (players .~ [player1, player2, player3]) $
initialGameState'
betValue = player1 ^. chips
pName = "player1"
newGame = makeBet betValue pName game
playerWhoBet = newGame ^? players . ix 0
expectedPlayer =
Player
{ _pockets = Nothing,
_chips = 0,
_bet = betValue,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 100 + betValue,
_actedThisTurn = True,
_possibleActions = []
}
playerWhoBet `shouldBe` Just expectedPlayer
it "should increment position to act" $ do
let game =
(street .~ PreFlop) . (currentPosToAct .~ pure 0)
. (players .~ [player1, player2, player3])
$ initialGameState'
betValue = 200
pName = "player1"
newGame = makeBet betValue pName game
newPositionToAct = newGame ^. currentPosToAct
expectedNewPositionToAct = Just 2
newPositionToAct `shouldBe` expectedNewPositionToAct
describe "foldCards" $ do
it "should update player attributes correctly" $ do
let game =
(street .~ PreFlop) . (players .~ [player1, player2, player3]) $
initialGameState'
pName = "player1"
newGame = foldCards pName game
playerWhoFolded = newGame ^? players . ix 0
expectedPlayer =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn Folded,
_playerName = "player1",
_committed = 100,
_actedThisTurn = True,
_possibleActions = []
}
playerWhoFolded `shouldBe` Just expectedPlayer
it "should increment position to act" $ do
let game =
(street .~ PreFlop) . (currentPosToAct .~ pure 0)
. (players .~ [player1, player2, player3])
$ initialGameState'
pName = "player1"
newGame = foldCards pName game
newPositionToAct = newGame ^. currentPosToAct
expectedNewPositionToAct = Just 2
newPositionToAct `shouldBe` expectedNewPositionToAct
describe "call" $ do
it "should update player attributes correctly when calling a bet" $ do
let game =
(street .~ PreFlop) . (maxBet .~ 400)
. (players .~ [player1, player6])
$ initialGameState'
pName = "player6"
newGame = call pName game
playerWhoCalled = newGame ^? players . ix 1
expectedPlayer =
Player
{ _pockets = Nothing,
_chips = 1800,
_bet = 400,
_playerStatus = SatIn NotFolded,
_playerName = "player6",
_committed = 450,
_actedThisTurn = True,
_possibleActions = []
}
playerWhoCalled `shouldBe` Just expectedPlayer
it "should update player attributes correctly when calling AllIn" $ do
let game' =
(street .~ PreFlop) . (maxBet .~ 4000)
. (players .~ [player5, player1])
$ initialGameState'
pName' = "player1"
newGame' = call pName' game'
playerWhoCalled' = newGame' ^? players . ix 1
expectedPlayer' =
Player
{ _pockets = Nothing,
_chips = 0,
_bet = 2000,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 2100,
_actedThisTurn = True,
_possibleActions = []
}
playerWhoCalled' `shouldBe` Just expectedPlayer'
it "should increment position to act" $ do
let game =
(street .~ PreFlop) . (currentPosToAct .~ pure 0)
. (players .~ [player1, player2, player3])
$ initialGameState'
pName = "player1"
newGame = call pName game
newPositionToAct = newGame ^. currentPosToAct
expectedNewPositionToAct = Just 2
newPositionToAct `shouldBe` expectedNewPositionToAct
describe "check" $ do
it "should update player attributes correctly" $ do
let game =
(street .~ PreFlop) . (players .~ [player1, player2]) $
initialGameState'
pName = "player1"
expectedPlayers = [player1, player2, player3]
newGame = check pName game
playerWhoChecked = newGame ^? players . ix 0
expectedPlayer = (actedThisTurn .~ True) player1
playerWhoChecked `shouldBe` Just expectedPlayer
it "should increment position to act" $ do
let game =
(street .~ PreFlop) . (currentPosToAct .~ pure 0)
. (players .~ [player1, player3])
$ initialGameState'
pName = "player1"
newGame = check pName game
newPositionToAct = newGame ^. currentPosToAct
expectedNewPositionToAct = Just 1
newPositionToAct `shouldBe` expectedNewPositionToAct
describe "SitOut" $
it "should set playerStatus to SatOut" $ do
let game =
(street .~ PreDeal) . (players .~ [player1, player6]) $
initialGameState'
pName = "player6"
expectedPlayer = (playerStatus .~ SatOut) player6
newGame = sitOut pName game
playerWhoChecked = newGame ^? players . ix 1
playerWhoChecked `shouldBe` Just expectedPlayer
================================================
FILE: server/test/Poker/ActionValidationSpec.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Poker.ActionValidationSpec where
import Control.Lens (element, (%~), (&), (.~), (?~))
import Data.Either (isLeft, isRight)
import Data.Text (Text)
import qualified Data.Text as T
import Hedgehog (Property, forAll, property, withDiscards, (===))
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Poker.ActionValidation
( canBet,
canCall,
canCheck,
canFold,
canPostBlind,
canRaise,
canShowOrMuckHand,
checkPlayerSatAtTable,
isPlayerActingOutOfTurn,
validateAction,
validateBlindAction,
)
import Poker.Game.Utils (initialDeck)
import Poker.Generators (allPStates, allPStreets, genGame)
import Poker.Poker (initialGameState)
import Poker.Types
( Action (Check, Fold, LeaveSeat', PostBlind, SitOut, Timeout),
Blind (BigBlind, SmallBlind),
CurrentPlayerToActErr (CurrentPlayerToActErr),
Deck (Deck),
Game (..),
GameErr (InvalidMove, NotAtTable),
HandRank (Pair),
InvalidMoveErr
( AlreadySatOut,
BetLessThanBigBlind,
CannotBetShouldRaiseInstead,
CannotCallZeroAmountCheckOrBetInstead,
CannotCheckShouldCallRaiseOrFold,
CannotLeaveSeatOutsidePreDeal,
CannotShowHandOrMuckHand,
CannotSitOutOutsidePreDeal,
InvalidActionForStreet,
NoPlayerCanAct,
NotEnoughChipsForAction,
OutOfTurn
),
Player
( Player,
_actedThisTurn,
_bet,
_chips,
_committed,
_playerName,
_playerStatus,
_pockets,
_possibleActions
),
PlayerShowdownHand (PlayerShowdownHand),
PlayerState (..),
SatInState (..),
Street (Flop, PreDeal, PreFlop, River, Showdown, Turn),
Winners (MultiPlayerShowdown, NoWinners, SinglePlayerShowdown),
actedThisTurn,
bet,
chips,
committed,
currentPosToAct,
dealer,
deck,
maxBet,
playerStatus,
players,
pot,
street,
winners,
)
import Test.Hspec (describe, it, shouldBe)
import Test.Hspec.Hedgehog
( PropertyT,
diff,
forAll,
hedgehog,
modifyMaxDiscardRatio,
(/==),
(===),
)
initialGameState' :: Game
initialGameState' = initialGameState initialDeck
player1 :: Player
player1 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 200,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 250,
_actedThisTurn = False,
_possibleActions = []
}
player2 :: Player
player2 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn Folded,
_playerName = "player2",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player3 :: Player
player3 =
Player
{ _pockets = Nothing,
_chips = 300,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player3",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player4 :: Player
player4 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatOut,
_playerName = "player4",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
}
player5 :: Player
player5 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player5",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
playerFixtures :: [Player]
playerFixtures = [player1, player2, player3, player4]
playerFixtures2 :: [Player]
playerFixtures2 = [player3, player5]
callAllInHeadsUpFixture :: Game
callAllInHeadsUpFixture =
Game
{ _dealer = 1,
_currentPosToAct = Just 0,
_smallBlind = 25,
_bigBlind = 50,
_minBuyInChips = 1500,
_maxBuyInChips = 3000,
_pot = 2500,
_maxBet = 2400,
_street = Turn,
_winners = NoWinners,
_board = [],
_maxPlayers = 6,
_waitlist = [],
_deck = Deck [],
_players =
[ Player
{ _pockets = Nothing,
_chips = 3500,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player0",
_committed = 50,
_actedThisTurn = True,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 0,
_bet = 2400,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 2450,
_actedThisTurn = True,
_possibleActions = []
}
]
}
preDealHeadsUpFixture :: Game
preDealHeadsUpFixture =
Game
{ _dealer = 0,
_currentPosToAct = Just 0,
_smallBlind = 25,
_bigBlind = 50,
_minBuyInChips = 1500,
_maxBuyInChips = 3000,
_pot = 50,
_maxBet = 50,
_street = PreDeal,
_winners = NoWinners,
_board = [],
_maxPlayers = 6,
_waitlist = [],
_deck = Deck [],
_players =
[ Player
{ _pockets = Nothing,
_chips = 3000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player0",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 2950,
_bet = 50,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 50,
_actedThisTurn = True,
_possibleActions = []
}
]
}
turnGameThreePlyrs :: Game
turnGameThreePlyrs =
Game
{ _dealer = 2,
_currentPosToAct = Just 0,
_smallBlind = 25,
_bigBlind = 50,
_minBuyInChips = 1500,
_maxBuyInChips = 3000,
_pot = 550,
_maxBet = 0,
_street = Turn,
_winners = NoWinners,
_board = [],
_maxPlayers = 6,
_waitlist = [],
_deck = Deck [],
_players =
[ Player
{ _pockets = Nothing,
_chips = 2197,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player0",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 1847,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 250,
_actedThisTurn = False,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 2072,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player2",
_committed = 250,
_actedThisTurn = False,
_possibleActions = []
}
]
}
spec = do
describe "Player Acting in Turn Validation" $ do
let game =
(currentPosToAct ?~ 0)
. (street .~ PreFlop)
. (players .~ playerFixtures)
$ initialGameState'
it
"returns Just OutOfTurn Error if given player is not in current position to act"
$ do
let playerName = "player3"
let expectedErr =
Left $
InvalidMove playerName $ OutOfTurn $ CurrentPlayerToActErr "player1"
isPlayerActingOutOfTurn game playerName `shouldBe` expectedErr
it
"returns return Right () when player is acting in turn during heads up game"
$ do
let game =
(street .~ PreFlop)
. (dealer .~ 0)
. (currentPosToAct ?~ 1)
. ( players
.~ [ ( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ False)
. (bet .~ 25)
. (committed .~ 25)
)
player1,
( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ False)
. (bet .~ 50)
. (committed .~ 50)
)
player2
]
)
$ initialGameState'
let playerName2 = "player2"
isPlayerActingOutOfTurn game playerName2 `shouldBe` Right ()
let game2 =
(street .~ PreFlop)
. (dealer .~ 1)
. (currentPosToAct ?~ 0)
. ( players
.~ [ ( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ False)
. (bet .~ 50)
. (committed .~ 50)
)
player1,
( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ True)
. (bet .~ 50)
. (committed .~ 50)
)
player2
]
)
$ initialGameState'
let playerName1 = "player1"
isPlayerActingOutOfTurn game2 playerName1 `shouldBe` Right ()
it "return no Error if player is acting in turn" $
isPlayerActingOutOfTurn game "player1" `shouldBe` Right ()
it "return no error for player acting in turn calling an all in during 2 plyr game" $
isPlayerActingOutOfTurn callAllInHeadsUpFixture "player0" `shouldBe` Right ()
it
"returns Just NotAtTable Error if no player with playerName is sat at table"
$ do
let expectedErr = Left $ NotAtTable "MissingPlayer"
checkPlayerSatAtTable game "MissingPlayer" `shouldBe` expectedErr
describe "canBet" $ do
it
"should return NotEnoughChipsForAction InvalidMoveErr if raise value is greater than remaining chips"
$ do
let game2 =
(players .~ playerFixtures2) . (street .~ Flop) $ initialGameState'
playerName = "player3"
amount = 10000
expectedErr = Left $ InvalidMove playerName $ NotEnoughChipsForAction
canBet playerName amount game2 `shouldBe` expectedErr
it
"should return CannotBetShouldRaiseInstead InvalidMoveErr if players have already bet or raised already"
$ do
let game2 =
(players .~ playerFixtures) . (street .~ Flop) . (maxBet .~ 100) $
initialGameState'
let playerName = "player3"
let amount = 50
let errMsg =
"A bet can only be carried out if no preceding player has bet"
let expectedErr =
Left $ InvalidMove playerName $ CannotBetShouldRaiseInstead errMsg
canBet playerName amount game2 `shouldBe` expectedErr
it
"should return BetLessThanBigBlind InvalidMoveErr if bet is less than the current big blind"
$ do
let game2 =
(players .~ playerFixtures2) . (street .~ Flop) $ initialGameState'
let playerName = "player3"
let amount = 2
let expectedErr = Left $ InvalidMove playerName $ BetLessThanBigBlind
canBet playerName amount game2 `shouldBe` expectedErr
it "should not return an error if player can bet" $ do
let game2 =
(players .~ playerFixtures2) . (maxBet .~ 0) . (street .~ Flop) $
initialGameState'
let playerName = "player3"
let amount = 100
canBet playerName amount game2 `shouldBe` Right ()
it
"should return InvalidActionForStreet InvalidMoveErr if game stage is PreDeal"
$ do
let preDealGame =
(street .~ PreDeal) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let amount = 100
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canBet playerName amount preDealGame `shouldBe` expectedErr
it
"should return InvalidActionForStreet InvalidMoveErr if game stage is Showdown"
$ do
let showdownGame =
(street .~ Showdown) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let amount = 100
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canBet playerName amount showdownGame `shouldBe` expectedErr
describe "canRaise" $ do
it
"should return InvalidActionForStreet InvalidMoveErr if game stage is PreDeal"
$ do
let preDealGame =
(street .~ PreDeal) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let amount = 100
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canBet playerName amount preDealGame `shouldBe` expectedErr
it "should return InvalidActionForStreet if game stage is PreDeal" $ do
let game =
(street .~ PreDeal) . (players .~ playerFixtures) $
initialGameState'
let playerName = "player3"
let amount = 50
let minRaise = 400
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canRaise playerName amount game `shouldBe` expectedErr
it
"should be able to raise all in when chip count is less than minimum raise amount"
$ do
let game =
(street .~ PreFlop) . (players .~ playerFixtures) . (maxBet .~ 200) $
initialGameState'
let playerName = "player3"
let amount = 300
canRaise playerName amount game `shouldBe` Right ()
it
"should return InvalidActionForStreet InvalidMoveErr if game stage is PreDeal"
$ do
let preDealGame =
(street .~ PreDeal) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let amount = 100
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canRaise playerName amount preDealGame `shouldBe` expectedErr
it
"should return InvalidActionForStreet InvalidMoveErr if game stage is Showdown"
$ do
let showdownGame =
(street .~ Showdown) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let amount = 100
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canRaise playerName amount showdownGame `shouldBe` expectedErr
describe "canCheck" $ do
it
"should return CannotCheckShouldCallRaiseOrFold InvalidMoveErr if maxBet is greater than zero and player bet is not equal to maxBet"
$ do
let game =
(street .~ PreFlop) . (players .~ playerFixtures) . (maxBet .~ 200) $
initialGameState'
let playerName = "player3"
let expectedErr =
Left $ InvalidMove playerName $ CannotCheckShouldCallRaiseOrFold
canCheck playerName game `shouldBe` expectedErr
it
"should allow BigBlind Blind player to check during PreFlop when no bets or raises have occurred"
$ do
let game =
(street .~ PreFlop)
. ( players
.~ [ ( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ True)
. (bet .~ 50)
. (committed .~ 50)
)
player1,
( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ False)
. (bet .~ 50)
. (committed .~ 50)
)
player2
]
)
$ initialGameState'
let playerName = "player2"
canCheck playerName game `shouldBe` Right ()
it
"should return InvalidActionForStreet InvalidMoveErr if game stage is PreDeal"
$ do
let preDealGame =
(street .~ PreDeal) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let amount = 100
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canCheck playerName preDealGame `shouldBe` expectedErr
it
"should return InvalidActionForStreet InvalidMoveErr if game stage is Showdown"
$ do
let showdownGame =
(street .~ Showdown) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let amount = 100
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canCheck playerName showdownGame `shouldBe` expectedErr
it "should be able to check when have chips and in position during 3 player game" $ do
let playerName = "player0"
validateAction turnGameThreePlyrs playerName Check `shouldBe` Right ()
describe "canCall" $ do
it
"should return InvalidActionForStreet InvalidMoveErr if game stage is PreDeal"
$ do
let preDealGame =
(street .~ PreDeal) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let amount = 100
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canCall playerName preDealGame `shouldBe` expectedErr
it
"should return InvalidActionForStreet InvalidMoveErr if game stage is Showdown"
$ do
let showdownGame =
(street .~ Showdown) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let amount = 100
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canCall playerName showdownGame `shouldBe` expectedErr
it
"should return CannotCallZeroAmountCheckOrBetInstead InvalidMoveErr if game stage is not Preflop"
$ do
let game =
(street .~ Flop) . (maxBet .~ 0) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player5"
let expectedErr =
Left $
InvalidMove playerName $ CannotCallZeroAmountCheckOrBetInstead
canCall playerName game `shouldBe` expectedErr
it "should not return error if call bigBlind during Preflop" $ do
let game =
(street .~ PreFlop) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player5"
canCall playerName game `shouldBe` Left (InvalidMove "player5" CannotCallZeroAmountCheckOrBetInstead)
describe "canFold" $ do
it
"should return InvalidActionForStreet InvalidMoveErr if game stage is PreDeal"
$ do
let preDealGame =
(street .~ PreDeal) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canFold playerName preDealGame `shouldBe` expectedErr
it
"should return InvalidActionForStreet InvalidMoveErr if game stage is Showdown"
$ do
let showdownGame =
(street .~ Showdown) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canFold playerName showdownGame `shouldBe` expectedErr
describe "canShowOrMuckHand" $ do
it "should return InvalidMoveErr if game stage is not Showdown" $ do
let preDealGame =
(street .~ PreDeal) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let expectedErr = Left $ InvalidMove playerName $ InvalidActionForStreet
canShowOrMuckHand playerName preDealGame `shouldBe` expectedErr
it "should return InvalidMoveErr if hand is not a singlePlayer showdown" $ do
let showdownGame =
(street .~ Showdown)
. (pot .~ 1000)
. (deck .~ initialDeck)
. ( winners
.~ MultiPlayerShowdown [((Pair, PlayerShowdownHand []), "player4")]
)
. ( players
.~ [ ((playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True)) player4,
((playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True)) player5
]
)
$ initialGameState'
let playerName = "player5"
let expectedErr =
Left $
InvalidMove playerName $
CannotShowHandOrMuckHand
"Can only show or muck cards if winner of single player pot during showdown"
canShowOrMuckHand playerName showdownGame `shouldBe` expectedErr
it
"should return InvalidMoveErr if action was not sent by winner of single player showdown"
$ do
let showdownGame =
(street .~ Showdown)
. (pot .~ 1000)
. (deck .~ initialDeck)
. (winners .~ SinglePlayerShowdown "player4")
. ( players
.~ [ ((playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True)) player4,
((playerStatus .~ SatIn Folded) . (actedThisTurn .~ True)) player5
]
)
$ initialGameState'
let playerName = "player5"
let expectedErr =
Left $
InvalidMove playerName $
CannotShowHandOrMuckHand "Not winner of hand"
canShowOrMuckHand playerName showdownGame `shouldBe` expectedErr
it
"should return no InvalidMoveErr if action was sent by winner of single player showdown"
$ do
let showdownGame =
(street .~ Showdown)
. (pot .~ 1000)
. (deck .~ initialDeck)
. (winners .~ SinglePlayerShowdown "player4")
. ( players
.~ [ ((playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True)) player4,
((playerStatus .~ SatIn Folded) . (actedThisTurn .~ True)) player5
]
)
$ initialGameState'
let playerName = "player4"
canShowOrMuckHand playerName showdownGame `shouldBe` Right ()
describe "canTimeout" $ do
it
"should return an error for Timeout if no player can act"
$ do
let preFlopGame =
(street .~ PreFlop) . (players .~ playerFixtures2) $
initialGameState'
let playerName = "player3"
let expectedErr =
Left $
InvalidMove "player3" NoPlayerCanAct
validateAction preFlopGame playerName Timeout `shouldBe` expectedErr
it "should return no error for Timeout when acting in turn" $ do
let preFlopGame = initialGameState' & (street .~ PreFlop) . (players .~ playerFixtures2) . (currentPosToAct ?~ 1)
let playerName = "player5"
validateAction preFlopGame playerName Timeout `shouldBe` Right ()
it
"should return InvalidActionForStreet InvalidMoveErr if Timeout action occurs during Showdown"
$ do
let showDownGame = initialGameState' & (street .~ Showdown) . (players .~ playerFixtures2)
let playerName = "player3"
let expectedErr = Left $ InvalidMove playerName InvalidActionForStreet
validateAction showDownGame playerName Timeout `shouldBe` expectedErr
it "should return err for LeaveSeat if game state is not PreDeal" $ do
let preFlopGame = initialGameState' & (street .~ PreFlop) . (players .~ playerFixtures2)
let playerName = "player3"
let expectedErr = InvalidMove "player3" CannotLeaveSeatOutsidePreDeal
validateAction preFlopGame playerName LeaveSeat'
`shouldBe` Left expectedErr
it "should return err for LeaveSeat if player is not sat at Table" $ do
let preDealGame = initialGameState' & (street .~ PreDeal) . (players .~ playerFixtures2)
let playerName = "playerX"
let expectedErr = NotAtTable playerName
validateAction preDealGame playerName LeaveSeat'
`shouldBe` Left expectedErr
it
"should return no err for leave seat if player is sat at table during PreDeal"
$ do
let preDealGame = initialGameState' & (street .~ PreDeal) . (players .~ playerFixtures2)
let playerName = "player3"
validateAction preDealGame playerName LeaveSeat' `shouldBe` Right ()
describe "canSitOut" $ do
it
"should allow player to sit out of the game during the PreDeal street if sat in"
$ do
let preDealGame =
(street .~ PreDeal)
. ( players
.~ [ ( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ False)
. (bet .~ 0)
. (committed .~ 0)
)
player1,
( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ False)
. (bet .~ 0)
. (committed .~ 0)
)
player2
]
)
$ initialGameState'
let playerName = "player1"
validateAction preDealGame playerName SitOut `shouldBe` Right ()
it "should return error if player is not at table" $ do
let preDealGame =
(street .~ PreFlop)
. ( players
.~ [ ( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ True)
. (bet .~ 50)
. (committed .~ 50)
)
player1,
( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ False)
. (bet .~ 50)
. (committed .~ 50)
)
player2
]
)
$ initialGameState'
let playerName = "player3"
let expectedErr = Left $ NotAtTable playerName
validateAction preDealGame playerName SitOut `shouldBe` expectedErr
it "should not allow player to sit out of the game if already sat out" $ do
let preDealGame =
(street .~ PreDeal)
. ( players
.~ [ ( (playerStatus .~ SatOut)
. (actedThisTurn .~ False)
. (bet .~ 0)
. (committed .~ 0)
)
player1,
( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ False)
. (bet .~ 0)
. (committed .~ 0)
)
player2
]
)
$ initialGameState'
let playerName = "player1"
let expectedErr = Left $ InvalidMove playerName AlreadySatOut
validateAction preDealGame playerName SitOut `shouldBe` expectedErr
it "should not allow player to sit out unless street is PreDeal" $ do
let preDealGame =
(street .~ PreFlop)
. ( players
.~ [ ( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ True)
. (bet .~ 50)
. (committed .~ 50)
)
player1,
( (playerStatus .~ SatIn NotFolded)
. (actedThisTurn .~ False)
. (bet .~ 50)
. (committed .~ 50)
)
player2
]
)
$ initialGameState'
let playerName = "player2"
let expectedErr = Left $ InvalidMove playerName CannotSitOutOutsidePreDeal
validateAction preDealGame playerName SitOut `shouldBe` expectedErr
describe "validateBlindAction" $
describe "Heads Up Game" $ do
let game' =
(street .~ PreDeal)
. (maxBet .~ 0)
. (pot .~ 0)
. (deck .~ initialDeck)
. (currentPosToAct ?~ 1)
. (dealer .~ 0)
. ( players
.~ [ ( (actedThisTurn .~ False)
. (playerStatus .~ SatIn NotFolded)
. (bet .~ 0)
. (chips .~ 2000)
. (committed .~ 0)
)
player1,
( (actedThisTurn .~ False)
. (playerStatus .~ SatIn NotFolded)
. (bet .~ 0)
. (committed .~ 0)
. (chips .~ 2000)
)
player2
]
)
$ initialGameState'
it "Player1 should require small blind" $
validateBlindAction game' (_playerName player1) SmallBlind
`shouldBe` Right ()
it "Player2 should require bigBlind" $
validateBlindAction game' (_playerName player2) BigBlind `shouldBe` Right ()
describe "canPostBlind" $
describe "Heads Up Game" $ do
let game' =
(street .~ PreDeal)
. (maxBet .~ 0)
. (pot .~ 0)
. (deck .~ initialDeck)
. (currentPosToAct ?~ 1)
. (dealer .~ 0)
. ( players
.~ [ ( (actedThisTurn .~ False)
. (playerStatus .~ SatIn NotFolded)
. (bet .~ 0)
. (chips .~ 2000)
. (committed .~ 0)
)
player1,
( (actedThisTurn .~ False)
. (playerStatus .~ SatIn NotFolded)
. (bet .~ 0)
. (committed .~ 0)
. (chips .~ 2000)
)
player2
]
)
$ initialGameState'
it "Player1 should be able to post small blind" $
canPostBlind game' (_playerName player1) SmallBlind `shouldBe` Right ()
describe "validateAction" $ do
describe "postBlinds" $ do
it "Player0 should be able to post small blind" $ do
let action' = PostBlind SmallBlind
let pName = "player0"
validateAction preDealHeadsUpFixture pName action' `shouldBe` Right ()
it "Player0 should not be able post big blind" $ do
let action' = PostBlind BigBlind
let pName = "player0"
isLeft (validateAction preDealHeadsUpFixture pName action') `shouldBe` True
it "Player1 should not be able post big blind when already posted big blind" $ do
let action' = PostBlind BigBlind
let pName = "player1"
isLeft (validateAction preDealHeadsUpFixture pName action') `shouldBe` True
it "Player1 should not be able post small blind when already posted big blind" $ do
let action' = PostBlind SmallBlind
let pName = "player1"
isLeft (validateAction preDealHeadsUpFixture pName action') `shouldBe` True
it "Players can't post a blind when they have no chips" $
hedgehog $ do
g <- forAll $ genGame [PreDeal] allPStates
blind' <- forAll $ Gen.element [SmallBlind, BigBlind]
let g' = g & players . element 0 %~ chips .~ 0
action' = PostBlind blind'
pName = "player0"
isLeft (validateAction g' pName action') === True
-- it "Players shouldn't be able to post blinds outside PreDeal" $
-- hedgehog $ do
-- g <- forAll $ genGame [PreFlop] [SatIn NotFolded, SatOut]
-- blind' <- forAll $ Gen.element [SmallBlind, BigBlind]
-- let action' = PostBlind blind'
-- pName = "player1"
-- isLeft (validateAction g pName action') === True
describe "fold" $
it "should always be able to fold when in turn" $
hedgehog $ do
g <- forAll $ genGame [PreFlop, Flop, Turn, River] [SatIn NotFolded]
let action' = Fold
pName = "player0"
inTurn = isRight $ isPlayerActingOutOfTurn g pName
allIn = (== 0) $ _chips $ head $ _players g
canFold = isRight $ validateAction g pName action'
canFold === (inTurn && not allIn)
================================================
FILE: server/test/Poker/BlindSpec.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Poker.BlindSpec where
import Control.Lens ((.~))
import Data.Text (Text)
import qualified Data.Text as T
import Hedgehog
( Property,
assert,
forAll,
property,
withDiscards,
)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Poker.Game.Blinds
( blindRequiredByPlayer,
getRequiredBlinds,
getSmallBlindPosition,
haveRequiredBlindsBeenPosted,
updatePlayersInHand,
)
import Poker.Game.Utils (getGamePlayerNames, initialDeck)
import Poker.Generators (allPStates, genGame)
import Poker.Poker (initPlayer, initialGameState)
import Poker.Types
( Blind (BigBlind, NoBlind, SmallBlind),
Deck (Deck),
Game (..),
Player (..),
PlayerState (..),
SatInState (..),
Street (PreDeal),
Winners (NoWinners),
playerStatus,
players,
)
import Test.Hspec (describe, it, shouldBe)
import Test.Hspec.Hedgehog
( PropertyT,
diff,
forAll,
hedgehog,
modifyMaxDiscardRatio,
(/==),
(===),
)
initialGameState' :: Game
initialGameState' = initialGameState initialDeck
twoPlayerGame :: Game
twoPlayerGame =
Game
{ _players =
[ Player
{ _pockets = Nothing,
_chips = 1950,
_bet = 50,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatOut,
_playerName = "player2",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
}
],
_maxPlayers = 5,
_board = [],
_waitlist = [],
_deck = Deck [],
_smallBlind = 25,
_bigBlind = 50,
_street = PreDeal,
_pot = 0,
_minBuyInChips = 1000,
_maxBuyInChips = 3000,
_maxBet = 0,
_dealer = 0,
_currentPosToAct = Just 1,
_winners = NoWinners
}
twoPlayerGameAllBlindsPosted :: Game
twoPlayerGameAllBlindsPosted =
Game
{ _players =
[ Player
{ _pockets = Nothing,
_chips = 1950,
_bet = 25,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 25,
_actedThisTurn = True,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 50,
_playerStatus = SatIn NotFolded,
_playerName = "player2",
_committed = 50,
_actedThisTurn = True,
_possibleActions = []
}
],
_maxPlayers = 5,
_board = [],
_waitlist = [],
_deck = Deck [],
_smallBlind = 25,
_bigBlind = 50,
_street = PreDeal,
_pot = 0,
_winners = NoWinners,
_maxBet = 0,
_dealer = 0,
_minBuyInChips = 1000,
_maxBuyInChips = 3000,
_currentPosToAct = Just 1
}
threePlayerGame :: Game
threePlayerGame =
Game
{ _players =
[ Player
{ _pockets = Nothing,
_chips = 1950,
_bet = 0,
_playerStatus = SatOut,
_playerName = "player1",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatOut,
_playerName = "player2",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatOut,
_playerName = "player3",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
}
],
_maxPlayers = 5,
_board = [],
_waitlist = [],
_deck = Deck [],
_smallBlind = 25,
_bigBlind = 50,
_street = PreDeal,
_pot = 0,
_winners = NoWinners,
_maxBet = 0,
_dealer = 0,
_minBuyInChips = 1000,
_maxBuyInChips = 3000,
_currentPosToAct = Just 1
}
threePlayerGameAllBlindsPosted :: Game
threePlayerGameAllBlindsPosted =
Game
{ _players =
[ Player
{ _pockets = Nothing,
_chips = 1950,
_bet = 0,
_playerStatus = SatOut,
_playerName = "player1",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 25,
_playerStatus = SatIn NotFolded,
_playerName = "player2",
_committed = 25,
_actedThisTurn = False,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 50,
_playerStatus = SatIn NotFolded,
_playerName = "player3",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
],
_maxPlayers = 5,
_board = [],
_waitlist = [],
_deck = Deck [],
_smallBlind = 25,
_bigBlind = 50,
_street = PreDeal,
_pot = 0,
_minBuyInChips = 1000,
_maxBuyInChips = 3000,
_winners = NoWinners,
_maxBet = 0,
_dealer = 0,
_currentPosToAct = Just 1
}
twoPlayerNames :: [Text]
twoPlayerNames = getGamePlayerNames twoPlayerGame
twoPlayers :: [Player]
twoPlayers = _players twoPlayerGame
threePlayerNames :: [Text]
threePlayerNames = getGamePlayerNames threePlayerGame
threePlayers :: [Player]
threePlayers = _players threePlayerGame
prop_requiredBlinds_always_valid_arrangement_for_2_plyrs :: Property
prop_requiredBlinds_always_valid_arrangement_for_2_plyrs = withDiscards 225 . property $ do
g <- forAll $ Gen.filter twoPlayers (genGame [PreDeal] allPStates)
let legalBlindArrangements = [[SmallBlind, BigBlind], [SmallBlindind, SmallBlind]]
requiredBlinds = getRequiredBlinds g
assert (requiredBlinds `elem` legalBlindArrangements)
where
twoPlayers = (== 2) . length . _players
prop_requiredBlinds_always_valid_arrangement_for_3_plyrs :: Property
prop_requiredBlinds_always_valid_arrangement_for_3_plyrs = withDiscards 225 . property $ do
g <- forAll $ Gen.filter threePlayer (genGame [PreDeal] allPStates)
let legalBlindArrangements = [[SmallBlind, BigBlind, NoBlind], [BigBlind,SmallBlindind, SmallBlind], SmallBlindind, SmallBlind, BigBlind]]
requiredBlinds = getRequiredBlinds g
assert (requiredBlinds `elem` legalBlindArrangements)
where
threePlayer = (== 3) . length . _players
spec = do
describe "blind required by player" $
it "should return correct blind" $
blindRequiredByPlayer twoPlayerGame "player2" `shouldBe` BigBlind
describe "getSmallBlindPosition" $ do
it "small blind position should be correct for a two player game" $ do
let dealerPos = 0
getSmallBlindPosition twoPlayerNames dealerPos `shouldBe` (0 :: Int)
it "small blind position should be correct for a three player game" $ do
let dealerPos = 2
getSmallBlindPosition threePlayerNames dealerPos `shouldBe` (0 :: Int)
describe "getRequiredBlinds" $ do
it "Should return valid required blinds for two player game" $
hedgehog $ do
let isTwoPlayers = (== 2) . length . _players
g <- forAll $ Gen.filter isTwoPlayers (genGame [PreDeal] allPStates)
let legalBlindArrangements = [[SmallBlind, BigBlind], [SmallBlindind, SmallBlind]]
requiredBlinds = getRequiredBlinds g
--
(requiredBlinds `elem` legalBlindArrangements) === True
it "Should return valid required blinds for three player game" $
hedgehog $ do
let isThreePlayers = (== 3) . length . _players
g <- forAll $ Gen.filter isThreePlayers (genGame [PreDeal] allPStates)
let legalBlindArrangements = [[SmallBlind, BigBlind, NoBlind], [BigBlind,SmallBlindind, SmallBlind], SmallBlindind, SmallBlind, BigBlind]]
requiredBlinds = getRequiredBlinds g
(requiredBlinds `elem` legalBlindArrangements) === True
describe "blinds" $ do
describe "getSmallBlindPosition" $ do
it "returns correct small blind position in three player game" $ do
let dealerPos = 0
getSmallBlindPosition ["Player1", "Player2", "Player3"] dealerPos
`shouldBe` 1
it "returns correct small blind position in two player game" $ do
let dealerPos = 0
getSmallBlindPosition ["Player1", "Player2"] dealerPos `shouldBe` 0
describe "blindRequiredByPlayer" $ do
it "returns SmallBlind if player position is dealer + 1 for three players" $ do
let testPlayers =
(playerStatus .~ SatIn NotFolded)
<$> (initPlayer <$> ["Player1", "Player2", "Player3"] <*> [100])
let game = players .~ testPlayers $ initialGameState'
blindRequiredByPlayer game "Player2" `shouldBe` SmallBlind
it "returns BigBlind if player position is dealer + 2 for three players" $ do
let testPlayers =
(playerStatus .~ SatIn NotFolded)
<$> (initPlayer <$> ["Player1", "Player2", "Player3"] <*> [100])
let game = players .~ testPlayers $ initialGameState'
blindRequiredByPlayer game "Player3" `shouldBe` BigBlind
it
"returns NoBlind if player position is dealer for three players and playerStatus is SatIn NotFolded"
$ do
let testPlayers =
(playerStatus .~ SatIn NotFolded)
<$> (initPlayer <$> ["Player1", "Player2", "Player3"] <*> [100])
let game = players .~ testPlayers $ initialGameState'
blindRequiredByPlayer game "Player1" `shouldBe` NoBlind
it
"returns BigBlind if player position is dealer for three players and playerStatus is SatOut"
$ do
let testPlayers =
(playerStatus .~ SatOut)
<$> (initPlayer <$> ["Player1", "Player2", "Player3"] <*> [100])
let game = players .~ testPlayers $ initialGameState'
blindRequiredByPlayer game "Player1" `shouldBe` NoBlind
it "returns SmallBlind if player position is dealer for two players" $ do
let testPlayers =
(playerStatus .~ SatIn NotFolded)
<$> (initPlayer <$> ["Player1", "Player2"] <*> [100])
let game = players .~ testPlayers $ initialGameState'
blindRequiredByPlayer game "Player1" `shouldBe` SmallBlind
it "returns BigBlind if player position is dealer + 1 for two players" $ do
let testPlayers = initPlayer <$> ["Player1", "Player2"] <*> [100]
let game = players .~ testPlayers $ initialGameState'
blindRequiredByPlayer game "Player2" `shouldBe` BigBlind
describe "haveRequiredBlindsBeenPosted" $ do
it
"should return False when not all players have posted blinds in 2 player game"
$ haveRequiredBlindsBeenPosted twoPlayerGame `shouldBe` False
it "should return True when all players have posted blinds in 2 player game" $
haveRequiredBlindsBeenPosted twoPlayerGameAllBlindsPosted `shouldBe` True
it
"should return False when not all players have posted blinds in 3 player game"
$ haveRequiredBlindsBeenPosted threePlayerGame `shouldBe` False
it
"should return True when all players have posted blinds in 3 player game"
$ haveRequiredBlindsBeenPosted threePlayerGameAllBlindsPosted
`shouldBe` True
describe "updatePlayersInHand" $ do
it
"should set players that are not in blind position to SatIn NotFolded for three players"
$ do
let newGame = updatePlayersInHand threePlayerGameAllBlindsPosted
let playerStates = (\Player {..} -> _playerStatus) <$> _players newGame
playerStates `shouldBe` [SatIn NotFolded, SatIn NotFolded, SatIn NotFolded]
it
"should return correct player states for two players when all blinds posted"
$ do
let newGame = updatePlayersInHand twoPlayerGameAllBlindsPosted
let playerStates = (\Player {..} -> _playerStatus) <$> _players newGame
playerStates `shouldBe` [SatIn NotFolded, SatIn NotFolded]
it
"should return correct player states for two players when not all blinds posted"
$ do
let newGame = updatePlayersInHand twoPlayerGame
let playerStates = (\Player {..} -> _playerStatus) <$> _players newGame
playerStates `shouldBe` [SatIn NotFolded, SatOut]
================================================
FILE: server/test/Poker/GameSpec.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Poker.GameSpec where
import Control.Lens (element, (%~), (&), (.~), (?~), (^.))
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Hedgehog
( Property,
assert,
forAll,
property,
withDiscards,
(===),
)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Poker.Game.Game
( allButOneAllIn,
allButOneFolded,
awaitingPlayerAction,
dealToPlayers,
doesPlayerHaveToAct,
everyoneAllIn,
getHandRankings,
getNextHand,
haveAllPlayersActed,
nextPosToAct,
progressToFlop,
progressToPreFlop,
progressToRiver,
progressToShowdown,
progressToTurn,
)
import Poker.Game.Utils (getActivePlayers, initialDeck)
import Poker.Generators
( allPStates,
allPStreets,
genGame,
genPlayer',
genPlayers,
)
import Poker.Poker (initialGameState)
import Poker.Types
( Card (Card, rank, suit),
Deck (Deck),
Game (..),
Player (..),
PlayerState (..),
PocketCards (PocketCards),
Rank (Four, King, Three),
SatInState (..),
Street (Flop, PreDeal, PreFlop, River, Showdown, Turn),
Suit (Clubs, Diamonds, Hearts, Spades),
Winners (NoWinners),
actedThisTurn,
bet,
chips,
committed,
currentPosToAct,
dealer,
deck,
maxBet,
playerStatus,
players,
pot,
smallBlind,
street,
)
import Test.Hspec (describe, it, shouldBe)
import Test.Hspec.Hedgehog
( PropertyT,
diff,
forAll,
hedgehog,
modifyMaxDiscardRatio,
(/==),
(===),
)
initialGameState' :: Game
initialGameState' = initialGameState initialDeck
player1 :: Player
player1 =
Player
{ _pockets =
Just $
PocketCards
Card {rank = Three, suit = Diamonds}
Card {rank = Four, suit = Spades},
_chips = 2000,
_bet = 50,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 50,
_actedThisTurn = True,
_possibleActions = []
}
player2 :: Player
player2 =
Player
{ _pockets =
Just $
PocketCards
Card {rank = Three, suit = Clubs}
Card {rank = Four, suit = Hearts},
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player2",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player3 :: Player
player3 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player3",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player4 :: Player
player4 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatOut,
_playerName = "player4",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
}
player5 :: Player
player5 =
Player
{ _pockets =
Just $
PocketCards
Card {rank = King, suit = Diamonds}
Card {rank = Four, suit = Spades},
_chips = 2000,
_bet = 50,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 50,
_actedThisTurn = True,
_possibleActions = []
}
player6 :: Player
player6 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatOut,
_playerName = "player6",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
}
initPlayers :: [Player]
initPlayers = [player1, player2, player3]
turnGameThreePlyrs :: Game
turnGameThreePlyrs =
Game
{ _dealer = 2,
_currentPosToAct = Just 0,
_smallBlind = 25,
_bigBlind = 50,
_minBuyInChips = 1500,
_maxBuyInChips = 3000,
_pot = 550,
_maxBet = 0,
_street = Turn,
_winners = NoWinners,
_board = [],
_maxPlayers = 6,
_waitlist = [],
_deck = Deck [],
_players =
[ Player
{ _pockets = Nothing,
_chips = 2197,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player0",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 1847,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 250,
_actedThisTurn = False,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 2072,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player2",
_committed = 250,
_actedThisTurn = False,
_possibleActions = []
}
]
}
spec = do
describe "dealToPlayers" $
it "should deal correct number of cards" $ do
let (_, newPlayers) = dealToPlayers initialDeck [player1, player3]
all
( \Player {..} ->
if _playerStatus == SatIn NotFolded
then isJust _pockets
else isNothing _pockets
)
newPlayers
`shouldBe` True
describe "haveAllPlayersActed" $ do
it
"should return True when all players have acted during PreDeal for Three Players"
$ do
let game =
(street .~ PreDeal) . (maxBet .~ 0)
. ( players
.~ [ ( (playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ False) . (bet .~ 0)
. (committed .~ 0)
)
player1,
( (playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True) . (bet .~ 0)
. (committed .~ 25)
)
player2,
( (playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True) . (bet .~ 0)
. (committed .~ 50)
)
player6
]
)
$ initialGameState'
haveAllPlayersActed game `shouldBe` True
it
"should return False when not all players acted during PreDeal for Three Players"
$ do
let unfinishedBlindsGame =
(street .~ PreDeal) . (players .~ [player1, player4, player6]) $
initialGameState'
haveAllPlayersActed unfinishedBlindsGame `shouldBe` False
it
"should return True when all players have acted during preFlop for Two Players"
$ do
let game =
(street .~ PreFlop) . (maxBet .~ 0)
. ( players
.~ [ ((playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True) . (bet .~ 0))
player1,
((playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True) . (bet .~ 0))
player2
]
)
$ initialGameState'
haveAllPlayersActed game `shouldBe` True
it
"should return False when not all players acted during PreFlop for Two Players"
$ do
let unfinishedBlindsGame =
(street .~ PreDeal) . (players .~ [player1, player4]) $
initialGameState'
haveAllPlayersActed unfinishedBlindsGame `shouldBe` False
describe "allButOneFolded" $ do
it "should return True when all but one player " $ do
let game =
(street .~ PreFlop)
. (players .~ [(playerStatus .~ SatIn Folded) player1, player2])
$ initialGameState'
allButOneFolded game `shouldBe` True
it "should return False when not all players acted" $ do
let unfinishedBlindsGame =
(street .~ PreFlop) . (players .~ [player1, player3]) $
initialGameState'
allButOneFolded unfinishedBlindsGame `shouldBe` False
it "should always return False for PreDeal (blinds) stage" $ do
let unfinishedBlindsGame =
(street .~ PreDeal)
. (players .~ [(playerStatus .~ SatIn Folded) player1, player2])
$ initialGameState'
allButOneFolded unfinishedBlindsGame `shouldBe` False
describe "progressToPreFlop" $ do
let preDealGame =
(street .~ PreDeal) . (maxBet .~ 50) . (pot .~ 75)
. (deck .~ initialDeck)
. ( players
.~ [ ((chips .~ 1000) . (committed .~ 25) . (bet .~ 25)) player5,
((chips .~ 1000) . (committed .~ 50) . (bet .~ 50)) player2
]
)
$ initialGameState'
let preFlopGame = progressToPreFlop preDealGame
it "should update street to PreFlop" $ preFlopGame ^. street `shouldBe` PreFlop
it "should not reset any player bet" $ do
let playerBets = (^. bet) <$> _players preFlopGame
playerBets `shouldBe` [25, 50]
it "Dealer position acts first during Preflop game stage when Heads Up (2 plyrs)" $ do
let game =
(street .~ PreDeal) . (currentPosToAct ?~ 0)
. (players .~ [player1, player1])
. (dealer .~ 0)
$ initialGameState'
_currentPosToAct preFlopGame `shouldBe` Just (_dealer game)
describe "progressToFlop" $ do
let preFlopGame =
(street .~ Flop) . (maxBet .~ 1000) . (pot .~ 1000)
. (deck .~ initialDeck)
. (players .~ [(chips .~ 1000) player5, (chips .~ 1000) player2])
$ initialGameState'
let flopGame = progressToFlop preFlopGame
it "should update street to Turn" $ flopGame ^. street `shouldBe` Flop
it "should reset maxBet" $ flopGame ^. maxBet `shouldBe` 0
it "should reset all player bets" $ do
let playerBets = (^. bet) <$> _players flopGame
playerBets `shouldBe` [0, 0]
describe "progressToTurn" $ do
let flopGame =
(street .~ Flop) . (maxBet .~ 1000) . (pot .~ 1000)
. (deck .~ initialDeck)
. (players .~ [(chips .~ 1000) player5, (chips .~ 1000) player2])
$ initialGameState'
let turnGame = progressToTurn flopGame
it "should update street to Turn" $ turnGame ^. street `shouldBe` Turn
it "should reset maxBet" $ turnGame ^. maxBet `shouldBe` 0
it "should reset all player bets" $ do
let playerBets = (^. bet) <$> _players turnGame
playerBets `shouldBe` [0, 0]
describe "progressToRiver" $ do
let turnGame =
(street .~ Turn) . (maxBet .~ 1000) . (pot .~ 1000)
. (deck .~ initialDeck)
. (players .~ [(chips .~ 1000) player5, (chips .~ 1000) player2])
$ initialGameState'
let riverGame = progressToRiver turnGame
it "should update street to River" $ riverGame ^. street `shouldBe` River
it "should reset maxBet" $ riverGame ^. maxBet `shouldBe` 0
it "should reset all player bets" $ do
let turnGame =
(street .~ Turn) . (maxBet .~ 1000) . (pot .~ 1000)
. (deck .~ initialDeck)
. (players .~ [(chips .~ 1000) player5, (chips .~ 1000) player2])
$ initialGameState'
let riverGame = progressToRiver turnGame
let playerBets = (^. bet) <$> _players riverGame
playerBets `shouldBe` [0, 0]
describe "progressToShowdown" $ do
let riverGame =
(street .~ River) . (pot .~ 1000) . (deck .~ initialDeck)
. (players .~ [(chips .~ 1000) player5, (chips .~ 1000) player2])
$ initialGameState'
let showdownGame = progressToShowdown riverGame
it "should update street to Turn" $ showdownGame ^. street `shouldBe` Showdown
it "should award pot chips to winner of hand" $ do
let playerChipCounts = (^. chips) <$> _players showdownGame
playerChipCounts `shouldBe` [2000, 1000]
it "should split pot if more than one player wins given pot" $ do
let riverGame =
(street .~ River) . (pot .~ 1000) . (deck .~ initialDeck)
. (players .~ [(chips .~ 1000) player1, (chips .~ 1000) player2])
$ initialGameState'
let showdownGame = progressToShowdown riverGame
let playerChipCounts =
(\Player {..} -> _chips) <$> _players showdownGame
playerChipCounts `shouldBe` [1500, 1500]
describe "getNextHand" $ do
let showdownGame =
(street .~ Showdown) . (maxBet .~ 1000) . (pot .~ 1000)
. (deck .~ initialDeck)
. (dealer .~ 1)
. (players .~ [(chips .~ 1000) player5, (chips .~ 1000) player2])
$ initialGameState'
let preDealGame = getNextHand showdownGame $ Deck []
it "should update street to PreDeal" $
preDealGame ^. street
`shouldBe` PreDeal
it "should reset maxBet" $ preDealGame ^. maxBet `shouldBe` 0
it "should reset all player bets" $ do
let playerBets = (\Player {..} -> _bet) <$> _players preDealGame
playerBets `shouldBe` [0, 0]
it "should increment dealer position" $ preDealGame ^. dealer `shouldBe` 0
describe "allButOneAllIn" $ do
it "should return False for two player game if no one all in" $ do
let preFlopGame' =
(street .~ PreFlop) . (pot .~ 1000) . (deck .~ initialDeck)
. ( players
.~ [ ((playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ False)) player1,
((playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True)) player3
]
)
$ initialGameState'
allButOneAllIn preFlopGame' `shouldBe` False
it "should return True for two player game if one player is all in and other isn't" $ do
let preFlopGame' =
(street .~ PreFlop) . (currentPosToAct ?~ 0) . (pot .~ 10) . (deck .~ initialDeck)
. ( players
.~ [ ((playerStatus .~ SatIn NotFolded) . (chips .~ 0) . (bet .~ 0) . (actedThisTurn .~ False)) player1,
((playerStatus .~ SatIn NotFolded) . (chips .~ 1) . (bet .~ 0) . (actedThisTurn .~ False)) player3
]
)
$ initialGameState'
allButOneAllIn preFlopGame' `shouldBe` True
it
"should return True for two player game if a player has called the other player all in"
$ do
let preFlopGame =
(street .~ PreFlop) . (maxBet .~ 1950) . (pot .~ 4000)
. (deck .~ initialDeck)
. ( players
.~ [ ( (actedThisTurn .~ True) . (playerStatus .~ SatIn NotFolded) . (bet .~ 1950)
. (chips .~ 0)
. (committed .~ 2000)
)
player1,
( (playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True) . (bet .~ 1950)
. (committed .~ 2000)
. (chips .~ 3000)
)
player3
]
)
$ initialGameState'
allButOneAllIn preFlopGame `shouldBe` True
it
"should return False for two player game if a player bet all in and the other has folded"
$ do
let preFlopGame =
(street .~ PreFlop) . (maxBet .~ 1950) . (pot .~ 4000)
. (deck .~ initialDeck)
. ( players
.~ [ ( (actedThisTurn .~ True) . (playerStatus .~ SatIn NotFolded) . (bet .~ 1950)
. (chips .~ 0)
. (committed .~ 2000)
)
player1,
( (playerStatus .~ SatIn Folded) . (actedThisTurn .~ True)
. (bet .~ 1950)
. (committed .~ 2000)
. (chips .~ 3000)
)
player3
]
)
$ initialGameState'
allButOneAllIn preFlopGame `shouldBe` False
it
"should return False for three player game if only one short stacked player all in"
$ do
let preFlopGame =
(street .~ PreFlop) . (maxBet .~ 1950) . (pot .~ 1000)
. (deck .~ initialDeck)
. ( players
.~ [ ( (actedThisTurn .~ True) . (playerStatus .~ SatIn NotFolded) . (bet .~ 1950)
. (chips .~ 0)
. (committed .~ 2000)
)
player1,
( (playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True) . (bet .~ 1950)
. (committed .~ 2000)
. (chips .~ 3000)
)
player3,
( (playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True) . (bet .~ 1950)
. (committed .~ 2000)
. (chips .~ 3000)
)
player3
]
)
$ initialGameState'
allButOneAllIn preFlopGame `shouldBe` False
it "should return True for four player game if only one player not all in" $ do
let flopGame =
(street .~ Flop) . (maxBet .~ 2000) . (pot .~ 10000)
. (deck .~ initialDeck)
. ( players
.~ [ ( (actedThisTurn .~ True) . (playerStatus .~ SatIn NotFolded) . (bet .~ 0)
. (chips .~ 0)
. (committed .~ 2000)
)
player1,
( (actedThisTurn .~ True) . (playerStatus .~ SatIn NotFolded) . (bet .~ 2000)
. (committed .~ 4000)
. (chips .~ 0)
)
player3,
( (playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True) . (bet .~ 2000)
. (committed .~ 4000)
. (chips .~ 0)
)
player3,
( (playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ False) . (bet .~ 0)
. (committed .~ 2000)
. (chips .~ 800)
)
player3
]
)
$ initialGameState'
allButOneAllIn flopGame `shouldBe` True
describe "everyoneAllIn" $
it "should return True for three player game if everyone is all in" $ do
let flopGame =
(street .~ Flop) . (maxBet .~ 2000) . (pot .~ 10000)
. (deck .~ initialDeck)
. ( players
.~ [ ( (actedThisTurn .~ True) . (playerStatus .~ SatIn NotFolded) . (bet .~ 0)
. (chips .~ 0)
. (committed .~ 2000)
)
player1,
( (actedThisTurn .~ True) . (playerStatus .~ SatIn NotFolded) . (bet .~ 2000)
. (committed .~ 4000)
. (chips .~ 0)
)
player3,
( (playerStatus .~ SatIn NotFolded) . (actedThisTurn .~ True) . (bet .~ 2000)
. (committed .~ 4000)
. (chips .~ 0)
)
player3
]
)
$ initialGameState'
everyoneAllIn flopGame `shouldBe` True
--describe "getHandRankings" $
-- it "Number of hand rankings should equal number of active players" $
-- hedgehog $ do
-- let requiredActives = 1
-- Deck deck = initialDeck
-- plyrCount <- forAll $ Gen.int $ Range.linear 2 9
-- (ps, cs) <- forAll $ genPlayers Showdown requiredActives allPStates plyrCount deck
-- length (getHandRankings ps cs) === length (getActivePlayers ps)
describe "doesPlayerHaveToAct" $ do
it "should be False when posToAct is not on player" $
hedgehog $ do
g <- forAll $ genGame [Flop] [SatIn NotFolded]
let g' = g & currentPosToAct ?~ 1
doesPlayerHaveToAct "player0" g' === False
it "should be False when player has no chips" $
hedgehog $ do
g <- forAll $ genGame [Flop] [SatIn NotFolded]
let g' = g & players . element 0 %~ chips .~ 0
doesPlayerHaveToAct "player0" g' === False
it "should be False when not enough players (<2) during predeal to start a game" $
hedgehog $ do
g <- forAll (genGame [PreDeal] allPStates)
(p, _) <- forAll $ genPlayer' PreDeal allPStates 0 []
let g' = g & players .~ [p]
doesPlayerHaveToAct "player0" g' === False
it "should return True for an active player in position" $ do
let game =
(street .~ Flop) . (dealer .~ 0) . (currentPosToAct ?~ 1)
. (players .~ [(chips .~ 1000) player5, (chips .~ 1000) player2])
$ initialGameState'
doesPlayerHaveToAct (_playerName player2) game `shouldBe` True
doesPlayerHaveToAct (_playerName player5) game `shouldBe` False
doesPlayerHaveToAct "player0" turnGameThreePlyrs `shouldBe` True
it "should return False for non-active players" $ do
let game =
(street .~ Flop) . (dealer .~ 0)
. ( players
.~ [ (chips .~ 1000) player5,
(playerStatus .~ SatIn Folded) player4,
(playerStatus .~ SatOut) player3,
(chips .~ 1000) player2
]
)
$ initialGameState'
doesPlayerHaveToAct (_playerName player3) game `shouldBe` False
doesPlayerHaveToAct (_playerName player4) game `shouldBe` False
describe "Heads Up Game" $
describe "PreDeal" $ do
describe "When 0 players sat in" $ do
let game' =
(street .~ PreDeal) . (maxBet .~ 0) . (pot .~ 0)
. (deck .~ initialDeck)
. (currentPosToAct .~ Nothing)
. (dealer .~ 0)
. ( players
.~ [ ( (actedThisTurn .~ False) . (playerStatus .~ SatOut)
. (bet .~ 0)
. (chips .~ 2000)
. (committed .~ 0)
. (bet .~ 0)
)
player1,
( (actedThisTurn .~ False) . (playerStatus .~ SatOut)
. (bet .~ 0)
. (committed .~ 0)
. (bet .~ 0)
. (chips .~ 2000)
)
player2
]
)
$ initialGameState'
it "No player should have to act first" $ do
doesPlayerHaveToAct (_playerName player1) game' `shouldBe` False
doesPlayerHaveToAct (_playerName player2) game' `shouldBe` False
describe "When 1 player is sat in" $ do
let game' =
(street .~ PreDeal)
. ( players
.~ [ ( (actedThisTurn .~ False) . (playerStatus .~ SatOut)
. (bet .~ 0)
. (chips .~ 2000)
. (committed .~ 0)
)
player1,
( (actedThisTurn .~ False) . (playerStatus .~ SatIn NotFolded) . (bet .~ 0)
. (committed .~ 0)
. (chips .~ 2000)
)
player2
]
)
$ initialGameState'
it "No player should have to act first" $ do
doesPlayerHaveToAct (_playerName player1) game' `shouldBe` False
doesPlayerHaveToAct (_playerName player2) game' `shouldBe` False
describe
"When 2 players are both sat in but no one has posted a blind yet"
$ do
let game' =
(street .~ PreDeal) . (maxBet .~ 0) . (pot .~ 0)
. (deck .~ initialDeck)
. (currentPosToAct ?~ 1)
. (dealer .~ 0)
. ( players
.~ [ ( (actedThisTurn .~ False) . (playerStatus .~ SatIn NotFolded) . (bet .~ 0)
. (chips .~ 2000)
. (committed .~ 0)
)
player1,
( (actedThisTurn .~ False) . (playerStatus .~ SatIn NotFolded) . (bet .~ 0)
. (committed .~ 0)
. (chips .~ 2000)
)
player2
]
)
$ initialGameState'
it "Player1 should not have to act" $
doesPlayerHaveToAct (_playerName player1) game'
`shouldBe` False
it "Player2 should not have to act" $
doesPlayerHaveToAct (_playerName player2) game'
`shouldBe` False
describe "When one player has already posted blinds" $ do
let game' =
(street .~ PreDeal) . (maxBet .~ 25) . (pot .~ 25)
. (deck .~ initialDeck)
. (currentPosToAct ?~ 1)
. (dealer .~ 0)
. ( players
.~ [ ( (actedThisTurn .~ True) . (playerStatus .~ SatIn NotFolded) . (bet .~ 0)
. (chips .~ 2000)
. (committed .~ 25)
)
player1,
( (actedThisTurn .~ False) . (playerStatus .~ SatIn NotFolded) . (bet .~ 0)
. (committed .~ 0)
. (chips .~ 1950)
)
player2
]
)
$ initialGameState'
it "Player1 should not have to act" $
doesPlayerHaveToAct (_playerName player1) game'
`shouldBe` False
it "Player2 should have to act" $
doesPlayerHaveToAct (_playerName player2) game'
`shouldBe` True
describe "PreFlop" $ do
describe "First Turn" $ do
let game' =
(street .~ PreFlop) . (maxBet .~ 50) . (deck .~ initialDeck)
. (smallBlind .~ 25)
. (smallBlind .~ 50)
. (pot .~ 100)
. (currentPosToAct ?~ 1)
. (dealer .~ 1)
. ( players
.~ [ ( (actedThisTurn .~ False) . (playerStatus .~ SatIn NotFolded)
. (bet .~ 50)
. (committed .~ 50)
. (chips .~ 1950)
)
player1,
( (actedThisTurn .~ False) . (playerStatus .~ SatIn NotFolded)
. (bet .~ 50)
. (chips .~ 1975)
. (committed .~ 50)
)
player2
]
)
$ initialGameState'
it "Player1 should not have to act" $
doesPlayerHaveToAct (_playerName player1) game'
`shouldBe` False
it "Player2 should have to act" $
doesPlayerHaveToAct (_playerName player2) game'
`shouldBe` True
describe "Second Turn" $ do
let game' =
(street .~ PreFlop) . (maxBet .~ 50) . (deck .~ initialDeck)
. (smallBlind .~ 25)
. (smallBlind .~ 50)
. (pot .~ 100)
. (currentPosToAct ?~ 1)
. (dealer .~ 1)
. ( players
.~ [ ( (actedThisTurn .~ True) . (playerStatus .~ SatIn NotFolded)
. (bet .~ 50)
. (committed .~ 50)
. (chips .~ 1950)
)
player1,
( (actedThisTurn .~ False) . (playerStatus .~ SatIn NotFolded)
. (bet .~ 50)
. (chips .~ 1975)
. (committed .~ 50)
)
player2
]
)
$ initialGameState'
it "Player1 should not have to act" $
doesPlayerHaveToAct (_playerName player1) game'
`shouldBe` False
it "Player2 should have to act" $
doesPlayerHaveToAct (_playerName player2) game'
`shouldBe` True
describe "Third Turn" $ do
let game' =
(street .~ PreFlop) . (maxBet .~ 50) . (pot .~ 0)
. (deck .~ initialDeck)
. (currentPosToAct ?~ 0)
. (dealer .~ 1)
. ( players
.~ [ ( (playerStatus .~ SatIn NotFolded) . (bet .~ 0) . (committed .~ 50)
. (chips .~ 1950)
)
player1,
( (actedThisTurn .~ True) . (playerStatus .~ SatIn NotFolded)
. (bet .~ 25)
. (chips .~ 1950)
. (committed .~ 50)
. (actedThisTurn .~ False)
)
player2
]
)
$ initialGameState'
it "Player1 should have to act" $
doesPlayerHaveToAct (_playerName player1) game'
`shouldBe` True
it "Player2 should not have to act" $
doesPlayerHaveToAct (_playerName player2) game'
`shouldBe` False
describe "Flop" $ do
describe "First turn" $ do
let game' =
(street .~ Flop) . (maxBet .~ 0) . (pot .~ 100)
. (deck .~ initialDeck)
. (currentPosToAct ?~ 1)
. (dealer .~ 0)
. ( players
.~ [ ( (actedThisTurn .~ False) . (playerStatus .~ SatIn NotFolded)
. (bet .~ 0)
. (chips .~ 2000)
. (committed .~ 50)
)
player1,
( (actedThisTurn .~ False) . (playerStatus .~ SatIn NotFolded)
. (bet .~ 0)
. (committed .~ 50)
. (chips .~ 2000)
)
player2
]
)
$ initialGameState'
it "Player1 should not have to act" $
doesPlayerHaveToAct (_playerName player1) game'
`shouldBe` False
it "Player2 should have to act" $
doesPlayerHaveToAct (_playerName player2) game'
`shouldBe` True
describe "Second turn" $ do
let game' =
(street .~ Flop) . (maxBet .~ 0) . (pot .~ 100)
. (deck .~ initialDeck)
. (currentPosToAct ?~ 0)
. (dealer .~ 0)
. ( players
.~ [ ( (actedThisTurn .~ False) . (playerStatus .~ SatIn NotFolded)
. (bet .~ 0)
. (chips .~ 2000)
. (committed .~ 50)
)
player1,
( (actedThisTurn .~ True) . (playerStatus .~ SatIn NotFolded) . (bet .~ 0)
. (committed .~ 50)
. (chips .~ 2000)
)
player2
]
)
$ initialGameState'
it "Player1 should have to act" $
doesPlayerHaveToAct (_playerName player1) game'
`shouldBe` True
it "Player2 should not have to act" $
doesPlayerHaveToAct (_playerName player2) game'
`shouldBe` False
describe "nextPosToAct" $ do
let player1 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 100,
_actedThisTurn = True,
_possibleActions = []
}
player2 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn Folded,
_playerName = "player2",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player3 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player3",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player4 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player3",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
}
player5 =
Player
{ _pockets = Nothing,
_chips = 4000,
_bet = 4000,
_playerStatus = SatIn NotFolded,
_playerName = "player5",
_committed = 4000,
_actedThisTurn = True,
_possibleActions = []
}
--it "nextPosToAct is always less than player count" $
-- hedgehog $ do
-- g <- forAll $ genGame allPStreets allPStates
-- let pCount = length $ _players g
-- nextPos = fromMaybe 0 (nextPosToAct g)
-- assert $ nextPos < pCount
--it "When everyone is all in then there should be no next player to act" $
-- hedgehog $ do
-- g <- forAll $ Gen.filter everyoneAllIn (genGame allPStreets allPStates)
-- nextPosToAct g === Nothing
it "When awaiting player action nextPosToAct should never be Nothing" $
hedgehog $ do
g <- forAll $ Gen.filter awaitingPlayerAction (genGame [PreFlop, Flop, Turn, River] [SatIn NotFolded, SatIn Folded])
isNothing (nextPosToAct g) === False
describe "Heads Up" $
it "should modulo increment position for two players who are both SatIn NotFolded" $ do
let game =
(street .~ PreFlop) . (currentPosToAct ?~ 0)
. (players .~ [player1, player3])
$ initialGameState'
nextPosToAct game `shouldBe` Just 1
let game2 =
(street .~ PreFlop) . (currentPosToAct ?~ 1)
. (players .~ [player1, player3])
$ initialGameState'
nextPosToAct game2 `shouldBe` Just 0
describe "Three Players" $ do
let threePGamePreFlop =
Game
{ _dealer = 2,
_currentPosToAct = Just 0,
_smallBlind = 25,
_bigBlind = 50,
_minBuyInChips = 1500,
_maxBuyInChips = 3000,
_pot = 100,
_maxBet = 50,
_street = PreFlop,
_winners = NoWinners,
_board = [],
_maxPlayers = 6,
_waitlist = [],
_deck = Deck [],
_players =
[ Player
{ _pockets = Nothing,
_chips = 2300,
_bet = 50,
_playerStatus = SatIn NotFolded,
_playerName = "player0",
_committed = 50,
_actedThisTurn = True,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 1700,
_bet = 50,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 50,
_actedThisTurn = True,
_possibleActions = []
},
Player
{ _pockets = Nothing,
_chips = 2122,
_bet = 0,
_playerStatus = SatIn Folded,
_playerName = "player2",
_committed = 0,
_actedThisTurn = True,
_possibleActions = []
}
]
}
it "Next position at end of PreDeal (PreFlop) should should skip folded player's position" $
nextPosToAct threePGamePreFlop `shouldBe` Just 1
it "Next position at end of PreDeal (PreFlop) should be left of big blind's (dealer's) position" $ do
let game2 =
(street .~ PreFlop) . (currentPosToAct ?~ 2)
. (players .~ [player1, player1, player1])
$ initialGameState'
nextPosToAct game2 `shouldBe` Just 1
it "Next position at end of Flop (Turn) should be small blind's position" $ do
let game2 =
(street .~ Flop) . (currentPosToAct ?~ 0)
. (players .~ [player1, player1, player1])
$ initialGameState'
nextPosToAct game2 `shouldBe` Just 1
it "should modulo increment position when one player has folded" $ do
let game2 =
(street .~ PreFlop) . (currentPosToAct ?~ 2)
. (players .~ [player1, player2, player3])
$ initialGameState'
nextPosToAct game2 `shouldBe` Just 0
describe "Four Players" $
it "should modulo increment position for four players" $ do
let game =
(street .~ PreFlop) . (currentPosToAct ?~ 2)
. (players .~ [player1, player4, player3, player2])
$ initialGameState'
nextPosToAct game `shouldBe` Just 0
let game2 =
(street .~ PreFlop) . (currentPosToAct ?~ 2)
. ( players
.~ [ player1,
player4,
player3,
(playerStatus .~ SatIn NotFolded) player2,
(playerStatus .~ SatIn NotFolded) player2
]
)
$ initialGameState'
nextPosToAct game2 `shouldBe` Just 3
let game3 =
(street .~ PreFlop) . (currentPosToAct ?~ 2)
. (players .~ [player2, player4, player3, player2])
$ initialGameState'
nextPosToAct game3 `shouldBe` Just 1
================================================
FILE: server/test/Poker/Generators.hs
================================================
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Poker.Generators where
import Control.Lens
( Field2 (_2),
FunctorWithIndex (imap),
(%~),
(.~),
(^.),
)
import Control.Monad (Monad (return), replicateM)
import Control.Monad.State (Monad (return), replicateM)
import Data.Either ()
import qualified Data.List as List
import Data.Maybe (Maybe (..))
import Data.Proxy ()
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text as Text
import Data.Traversable (mapAccumR)
import Data.Tuple (fst, swap)
import qualified Data.Vector as V
import Debug.Trace ()
import GHC.Enum (Enum (fromEnum))
import Hedgehog (Gen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Poker.Game.Game (getWinners, nextIxPlayerToAct)
import Poker.Game.Utils
( getActivePlayers,
getPlayersSatIn,
initialDeck,
)
import Poker.Types
( Card (suit),
Deck (..),
Game (..),
Player (..),
PlayerName,
PlayerState (..),
PocketCards (..),
SatInState (..),
Street (..),
Suit (Diamonds, Spades),
Winners (NoWinners),
bet,
playerName,
unDeck,
)
import Prelude
allPStates :: [PlayerState]
allPStates = [SatOut, SatIn Folded, SatIn NotFolded]
allPStreets :: [Street]
allPStreets = [PreDeal ..]
numBoardCards :: Street -> Int
numBoardCards =
\case
PreDeal -> 0
PreFlop -> 0
Flop -> 3
Turn -> 4
River -> 5
Showdown -> 5
genShuffledCards :: Int -> Gen [Card]
genShuffledCards n = do
cs <- Gen.shuffle $ unDeck initialDeck
return $ take n cs
genShuffledDeck :: Gen Deck
genShuffledDeck = do
cs <- Gen.shuffle $ unDeck initialDeck
return $ Deck cs
genSuit :: Gen Suit
genSuit = Gen.enum Diamonds Spades
genSameSuitCards :: Int -> Gen [Card]
genSameSuitCards n = do
suit' <- genSuit
cs <- Gen.shuffle $ filter ((== suit') . suit) (unDeck initialDeck)
return $ take n cs
genDealPockets :: [Card] -> Gen (Maybe PocketCards, [Card])
genDealPockets cs = do
let ([c1, c2], remainingCs) = splitAt 2 cs
return (Just $ PocketCards c1 c2, remainingCs)
genNoPockets :: [Card] -> Gen (Maybe PocketCards, [Card])
genNoPockets cs = return (Nothing, cs)
genPlayers :: Street -> Int -> [PlayerState] -> Int -> [Card] -> Gen ([Player], [Card])
genPlayers street' requiredInPlayers possibleStates playerCount cs = do
ps <- replicateM playerCount $ do
pState <- Gen.element possibleStates
genPlayer street' pState "player" Nothing
if activesCount ps < requiredInPlayers || street' `elem` actionStages && satInCount ps < 2
then Gen.discard
else return $ swap $ dealPlayersGen ps cs
where
actionStages = [PreFlop, Flop, Turn, River]
activesCount ps = length $ getActivePlayers ps
satInCount ps = length $ getPlayersSatIn ps
dealPlayersGen :: [Player] -> [Card] -> ([Card], [Player])
dealPlayersGen ps cs =
_2 %~ nameByPos $
mapAccumR
( \cs p ->
let (maybeDealtP, remainingCs') = dealPlayer cs p
in (remainingCs', maybeDealtP)
)
cs
ps
where
newName pos = playerName .~ "player" <> T.pack (show pos)
nameByPos ps = imap newName ps
dealPlayer cs plyr@Player {..}
| _playerStatus == SatOut = (plyr, cs)
| otherwise = (,) Player {_pockets = Just $ PocketCards c1 c2, ..} remainingCs'
where
([c1, c2], remainingCs') = splitAt 2 cs
genPlayer' :: Street -> [PlayerState] -> Int -> [Card] -> Gen (Player, [Card])
genPlayer' street' possibleStates position cs = do
pState <- Gen.element possibleStates
let shouldDeal = pState /= SatOut || null cs
(pocketCs, remainingCs) <- if shouldDeal then genDealPockets cs else genNoPockets cs
p <- genPlayer street' pState pName pocketCs
return (p, remainingCs)
where
pName = "player" <> T.pack (show position)
-- if given Just cards then will deal player (as long as not sat out) and return the remaining cards
--
-- minChips is calculated to reflect fact that a player can't fold if was all in (no action possible when chips 0)
-- a player who has state set to Folded and has 0 chips is not a valid player state
genPlayer :: Street -> PlayerState -> PlayerName -> Maybe PocketCards -> Gen Player
genPlayer street' _playerStatus _playerName _pockets = do
_chips <- Gen.int $ Range.linear minChips 10000
_committed <- if _playerStatus == SatOut then Gen.constant 0 else Gen.int $ Range.linear 0 10000
_bet <- if street' == PreDeal then Gen.constant 0 else Gen.int $ Range.linear 0 _committed
_actedThisTurn <- if _playerStatus == SatOut then Gen.constant False else Gen.bool
return Player {..}
where
minChips = if _playerStatus == SatIn Folded then 1 else 0
_possibleActions = []
genGame :: [Street] -> [PlayerState] -> Gen Game
genGame possibleStreets pStates = do
_street <- Gen.element possibleStreets
let d@(Deck cs) = initialDeck
let boardCount = numBoardCards _street
(boardCards, remainingCs) = splitAt boardCount cs
_smallBlind <- Gen.int $ Range.linear 1 100
_maxPlayers <- Gen.int $ Range.linear 2 9
playerCount <- Gen.int $ Range.linear 2 _maxPlayers
let requiredInPlyrs = if _street == Showdown then 2 else 0
(_players, remainingCs') <- genPlayers _street requiredInPlyrs pStates playerCount remainingCs
let _waitlist = []
_bigBlind = _smallBlind * 2
_maxBuyInChips = _bigBlind * 200
_minBuyInChips = _bigBlind * 100
(_board, remainingCs'') = splitAt (numBoardCards _street) remainingCs'
_deck = Deck remainingCs''
betsThisRound = (^. bet) <$> _players
_maxBet = maximum betsThisRound
betSum = sum betsThisRound
playerCount = length _players
_winners = if _street == Showdown then getWinners Game {..} else NoWinners
_pot <- Gen.int $ Range.linear betSum (betSum * fromEnum _street)
_dealer <- Gen.int $ Range.linear 0 (playerCount - 1)
_currentPosToAct' <- Gen.int $ Range.linear 0 (playerCount - 1)
let g'' = Game {..}
_currentPosToAct = fst <$> nextIxPlayerToAct g'' (Just _dealer)
return Game {..}
================================================
FILE: server/test/Poker/HandSpec.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Poker.HandSpec where
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Hedgehog (Property, forAll, property, (===))
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Poker.Game.Hands (maybeFlush, value)
import Poker.Generators (genSameSuitCards, genShuffledCards)
import Test.Hspec (describe, it)
import Test.Hspec.Hedgehog
( PropertyT,
diff,
forAll,
hedgehog,
modifyMaxDiscardRatio,
(/==),
(===),
)
spec = do
describe "value" $ do
it "Number of cards before and after valuation is involutive" $
hedgehog $ do
sevenCards <- forAll (genShuffledCards 7)
let (_, cs) = value sevenCards
length cs === 5
it "7 suited cards always a flush" $
hedgehog $ do
cs <- forAll $ genSameSuitCards 7
isJust (maybeFlush cs) === True
================================================
FILE: server/test/Poker/UtilsSpec.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Poker.UtilsSpec where
import Control.Lens ((.~))
import Data.List ()
import Data.List.Lens ()
import Data.Text (Text)
import qualified Data.Text as T
import Hedgehog (forAll, (===))
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Poker.ActionValidation ()
import Poker.Game.Utils (initialDeck, modInc)
import Poker.Poker (initialGameState)
import Poker.Types
( Game,
Player (..),
PlayerState (..),
SatInState (..),
Street (PreFlop),
players,
street,
)
import Test.Hspec (describe, it, shouldBe)
import Test.Hspec.Hedgehog
( PropertyT,
diff,
forAll,
hedgehog,
modifyMaxDiscardRatio,
(/==),
(===),
)
initialGameState' :: Game
initialGameState' = initialGameState initialDeck
player1 :: Player
player1 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 100,
_actedThisTurn = True,
_possibleActions = []
}
player2 :: Player
player2 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn Folded,
_playerName = "player2",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player3 :: Player
player3 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player3",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player4 :: Player
player4 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player3",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
}
player5 :: Player
player5 =
Player
{ _pockets = Nothing,
_chips = 4000,
_bet = 4000,
_playerStatus = SatIn NotFolded,
_playerName = "player5",
_committed = 4000,
_actedThisTurn = True,
_possibleActions = []
}
player6 :: Player
player6 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 200,
_playerStatus = SatIn NotFolded,
_playerName = "player6",
_committed = 250,
_actedThisTurn = True,
_possibleActions = []
}
bettingFinishedGame :: Game
bettingFinishedGame =
((players .~ [player1, player2]) . (street .~ PreFlop)) initialGameState'
bettingNotFinishedGame :: Game
bettingNotFinishedGame =
((players .~ [player1, player2, player3, player4]) . (street .~ PreFlop))
initialGameState'
spec = do
describe "ModInc" $ do
it "should increment in modulo fashion" $ do
modInc 1 0 2 `shouldBe` 1
modInc 1 1 1 `shouldBe` 0
modInc 1 6 7 `shouldBe` 7
it "result should always be greater than zero" $ do
hedgehog $ do
i <- forAll $ Gen.int $ Range.linear 0 9
(modInc 1 i 9 >= 0) === True
================================================
FILE: server/test/PokerSpec.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module PokerSpec where
import Data.Text (Text)
import qualified Data.Text as T
import Hedgehog (Property, forAll, property, withDiscards, (===))
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Poker.Game.Game (haveAllPlayersActed)
import Poker.Game.Utils (getActivePlayers)
import Poker.Generators (allPStates, genGame)
import Poker.Poker (canProgressGame)
import Poker.Types
import Test.Hspec (SpecWith, describe, it)
import Test.Hspec.Hedgehog (forAll, hedgehog, (===))
player1 :: Player
player1 =
Player
{ _pockets =
Just $
PocketCards
Card {rank = Three, suit = Diamonds}
Card {rank = Four, suit = Spades},
_chips = 2000,
_bet = 50,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 50,
_actedThisTurn = True,
_possibleActions = []
}
player2 :: Player
player2 =
Player
{ _pockets =
Just $
PocketCards
Card {rank = Three, suit = Clubs}
Card {rank = Four, suit = Hearts},
_chips = 0,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player2",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player3 :: Player
player3 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatIn NotFolded,
_playerName = "player3",
_committed = 50,
_actedThisTurn = False,
_possibleActions = []
}
player4 :: Player
player4 =
Player
{ _pockets = Nothing,
_chips = 2000,
_bet = 0,
_playerStatus = SatOut,
_playerName = "player4",
_committed = 0,
_actedThisTurn = False,
_possibleActions = []
}
player5 :: Player
player5 =
Player
{ _pockets =
Just $
PocketCards
Card {rank = King, suit = Diamonds}
Card {rank = Four, suit = Spades},
_chips = 2000,
_bet = 50,
_playerStatus = SatIn NotFolded,
_playerName = "player1",
_committed = 50,
_actedThisTurn = True,
_possibleActions = []
}
initPlayers :: [Player]
initPlayers = [player1, player2, player3]
spec :: SpecWith ()
spec = describe "Poker" $ do
return ()
================================================
FILE: server/test/Spec.hs
================================================
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}