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