├── .gitignore ├── .hindent.yaml ├── .hlint.yaml ├── LICENSE ├── README.md ├── apps └── SpeedTest.hs ├── package.yaml ├── scripts ├── dbbackup.sh └── restoredb.sh ├── snaplets └── heist │ └── templates │ ├── default.tpl │ ├── passwordchangegood.tpl │ └── resetpassword.tpl ├── sql └── moveevals.sql ├── src ├── AppTypes.hs ├── Application.hs ├── Main.hs ├── Services │ ├── DatabaseHelpers.hs │ ├── Helpers.hs │ ├── Openings.hs │ ├── Service.hs │ ├── Sql.hs │ ├── StatsHelpers.hs │ ├── Tasks.hs │ └── Types.hs └── Test │ ├── Fixtures.hs │ └── Helpers.hs ├── stack.yaml └── test ├── FillDB.hs ├── Spec.hs ├── wipe_table.sh └── wipe_table.sql /.gitignore: -------------------------------------------------------------------------------- 1 | *.sw* 2 | .stack*/ 3 | *.lock 4 | data/ 5 | site_key* 6 | cookies.txt 7 | log/ 8 | private_notes.md 9 | MonadCatchIO-transformers/ 10 | schema.txt 11 | private_notes.md 12 | 13 | snaplets/chess 14 | snaplets/elq 15 | snaplets/log 16 | snaplets/persist 17 | snaplets/persist-auth 18 | snaplets/postgresql-simple 19 | snaplets/service 20 | snaplets/site_key.txt 21 | snaplets/snaplets 22 | *.dump 23 | notes.md 24 | chess-backend.cabal 25 | error.txt 26 | log.txt 27 | 28 | -------------------------------------------------------------------------------- /.hindent.yaml: -------------------------------------------------------------------------------- 1 | indent-size: 2 2 | line-length: 90 3 | force-trailing-newline: true 4 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | 9 | # Specify additional command line arguments 10 | # 11 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 12 | 13 | 14 | # Control which extensions/flags/modules/functions can be used 15 | # 16 | # - extensions: 17 | # - default: false # all extension are banned by default 18 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 19 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 20 | # 21 | # - flags: 22 | # - {name: -w, within: []} # -w is allowed nowhere 23 | # 24 | # - modules: 25 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 26 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 27 | # 28 | # - functions: 29 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 30 | 31 | 32 | # Add custom hints for this project 33 | # 34 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 35 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 36 | 37 | 38 | # Turn on hints that are off by default 39 | # 40 | # Ban "module X(module X) where", to require a real export list 41 | # - warn: {name: Use explicit module export list} 42 | # 43 | # Replace a $ b $ c with a . b $ c 44 | # - group: {name: dollar, enabled: true} 45 | # 46 | # Generalise map to fmap, ++ to <> 47 | # - group: {name: generalise, enabled: true} 48 | 49 | 50 | # Ignore some builtin hints 51 | 52 | # TODO: This is weidly not found by stack build. Need to understand why 53 | - ignore: {name: Use traverse_} 54 | # - ignore: {name: Use let} 55 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 56 | 57 | 58 | # Define some custom infix operators 59 | # - fixity: infixr 3 ~^#^~ 60 | 61 | 62 | # To generate a suitable file for HLint do: 63 | # $ hlint --default > .hlint.yaml 64 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2018 Chris Goldammer 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Chess-backend 2 | 3 | ## Overview 4 | 5 | This is the backend that powers the chess analytics web tool. Fundamentally, the goal of the backend is to provide a JSON API that's consumed by the frontend. 6 | 7 | The backend consists of two parts: 8 | - An application to parse external chess databases into the backend database 9 | - A web server that provides API endpoints 10 | 11 | ## Main features 12 | 13 | ### Parsing external data 14 | 15 | The external data for chess games comes in through a list of text files in Pgn format. A Pgn file simply describes the moves in a game. The main goal is to put this data into a SQL database is to allow a variety of queries. The philosophy is that this step should do as much of the hard work as possible, so that the resulting data is not corrupt and easy to query. 16 | 17 | This library provides the `fill_db` application which takes those text files, parses them into games, and stores the relevant information in the database. The information in a Pgn file is unstructured. For instance, a player is referred to by their name "Carlsen, Magnus". The goal is to turn this into structured, queryable data, which includes the following: 18 | - `Player` with a first and last name 19 | - `Game`, which requires a player with the white and black pieces and a result. The `Game` includes a Pgn of the moves, and the moves are checked to parse into a game. 20 | - A `MoveEval`, which provides an evaluation of every single position in the game. This data can be used to calculate how closely a player's moves match the recommendations by the computer. 21 | 22 | ### API endpoints 23 | 24 | The API is provided by Servant. The beauty of Servant is that the API is fundamentally defined by it's (quite readable) type. The endpoints correspond to data pulls, for instance there is one data pull to obtain all the tournaments in the database, and another one to provide average evaluations by mover number. 25 | 26 | When the resulting data pull is straightforward, for instance to get the list of tournaments, the API is a wrapper on top of a SQL query, which I try to do using Esqueleto. Other API endpoints, e.g. the move number evaluations, require more complicated data transformations that are done in Haskell proper. 27 | 28 | ## Todo 29 | 30 | The website (prod) not provide all the features that are available the development (dev) version. 31 | 32 | The next big feature that rolls out will be user accounts, and the ability to upload own databases 33 | 34 | ### Additional statistics 35 | 36 | - Summarize pawn structures 37 | - Summarize playing style: How often do players exchange queens early, how often do they sacrifice? 38 | - Show the win percentage based on evaluation. For instance, I would guess that, if you play someone who's rated 500 points higher than you, your win expectation will still be low even if your position is +2. 39 | - Special window to prepare against opponent. This should show a player's openings and playing style 40 | 41 | ### Infrastructure 42 | 43 | - Improve nginx caching 44 | - Expand unit tests to cover all API endpoints and test user management features 45 | 46 | ## Technology 47 | 48 | ### Overview 49 | 50 | - This backend is written in Haskell. I use Snap to provide the web server, and Servant to provide the API inside the web server. For now, using Snap is overkill, but it will come in handy when allowing for user accounts and permissions. 51 | 52 | - I use a postgres database, which I access using Persistent and Esqueleto. 53 | - Everything is run on a single EC2 instance on AWS. 54 | 55 | ### Technical challenges and bottlenecks 56 | 57 | Currently, the biggest challenge is that it takes a long time to read in the data and store evaluations. I find that one obtains reasonable evaluations with about 100ms of search time, but that means that parsing a database of, say, 1M games is prohibitive. I am considering running a cluster of EC2 instances to speed this up as needed. 58 | -------------------------------------------------------------------------------- /apps/SpeedTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies #-} 2 | 3 | module Main where 4 | 5 | import Services.Helpers 6 | import Services.Service 7 | import qualified Test.Helpers as TH 8 | import Database.Esqueleto hiding (get) 9 | import Services.DatabaseHelpers 10 | import Database.Persist hiding ((==.)) 11 | import Database.Persist.Sql hiding ((==.)) 12 | 13 | import Services.Types 14 | 15 | 16 | main :: IO () 17 | main = do 18 | (players, evals) <- TH.inBackend (connString dbName) dataResults 19 | let summ = summarizeEvals players evals 20 | print $ length summ 21 | 22 | getTestEvals :: TH.DataAction [EvalResult] 23 | getTestEvals = do 24 | er <- select $ 25 | from $ \(me, g) -> do 26 | where_ $ (me^.MoveEvalGameId ==. g^.GameId) 27 | return (me, g) 28 | return er 29 | 30 | dbName :: String 31 | dbName = "prod" 32 | 33 | dataResults :: TH.DataAction ([Entity Player], [EvalResult]) 34 | dataResults = do 35 | dbPlayers :: [Entity Player] <- selectList [] [] 36 | evals <- getTestEvals 37 | return (dbPlayers, evals) 38 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: chess-backend 2 | version: 0.4 3 | description: Backend for chessinsights.org 4 | maintainer: Chris Goldammer (goldammer.christian@gmail.com) 5 | 6 | dependencies: 7 | - base >= 4.6 && < 4.14 8 | - snap >= 1.0.4.1 9 | - snap-core >= 1.0.4.1 10 | - snap-server >= 1.0.4.1 11 | - servant-snap 12 | - servant 13 | - esqueleto 14 | - heist 15 | 16 | - postgresql-simple 17 | - persistent 18 | - persistent-template 19 | - persistent-postgresql 20 | - snaplet-persistent 21 | - snaplet-postgresql-simple 22 | - esqueleto 23 | 24 | - chess 25 | 26 | - attoparsec 27 | - parsec 28 | - string-conversions 29 | - raw-strings-qq 30 | - bytestring 31 | - text 32 | - aeson 33 | 34 | - mtl 35 | - monad-logger 36 | - monad-control 37 | - comonad 38 | - transformers 39 | - lens-tutorial 40 | - time 41 | - map-syntax 42 | - containers 43 | 44 | - lens 45 | - resourcet 46 | - conduit 47 | - js-jquery 48 | - configurator 49 | - turtle 50 | - system-filepath 51 | - template 52 | 53 | - http-client 54 | - http-client-tls 55 | - smtp-mail >= 0.3.0.0 56 | - mime-mail >= 0.5.0 57 | - mime-mail-ses >= 0.4.3 58 | 59 | - listsafe 60 | - either 61 | - split 62 | - random 63 | - random-shuffle 64 | - directory 65 | 66 | executable: 67 | main: Main.hs 68 | source-dirs: src 69 | 70 | tests: 71 | spec: 72 | main: Spec.hs 73 | source-dirs: 74 | - test 75 | - src 76 | dependencies: 77 | - hspec 78 | - QuickCheck 79 | - HUnit 80 | - hspec-snap 81 | - optparse-applicative 82 | -------------------------------------------------------------------------------- /scripts/dbbackup.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -e 3 | 4 | APP=$1 5 | DB_NAME=$2 6 | 7 | BUCKET_NAME=chessinsightsbackup 8 | 9 | TIMESTAMP=$(date +%F_%T | tr ':' '-') 10 | TEMP_FILE=$(mktemp tmp.XXXXXXXXXX) 11 | S3_FILE="s3://$BUCKET_NAME/$APP/$APP-backup-$TIMESTAMP" 12 | 13 | pg_dump -Fc --no-acl -h localhost -U postgres $DB_NAME > ~/backup/$TEMP_FILE 14 | s3cmd put ~/backup/$TEMP_FILE $S3_FILE --encrypt 15 | 16 | # Delete backups older than 60 days 17 | find ~/backup -maxdepth 1 -mtime +60 -type f -delete 18 | -------------------------------------------------------------------------------- /scripts/restoredb.sh: -------------------------------------------------------------------------------- 1 | pg_restore -C -v -d postgres -U postgres backup 2 | -------------------------------------------------------------------------------- /snaplets/heist/templates/default.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | Home Page 4 | 5 | 6 | 9 |
10 | 11 |
12 | 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /snaplets/heist/templates/passwordchangegood.tpl: -------------------------------------------------------------------------------- 1 | 2 |

Password change successful

3 |

Log in with your new password

4 | 5 | -------------------------------------------------------------------------------- /snaplets/heist/templates/resetpassword.tpl: -------------------------------------------------------------------------------- 1 | 2 | 34 |

Reset password

35 |
36 | Password: 37 | Repeat password: 38 | 39 | 40 | 41 |

42 |
43 | 50 | 51 | -------------------------------------------------------------------------------- /sql/moveevals.sql: -------------------------------------------------------------------------------- 1 | -- General overview over the games and evaluations in the database 2 | SELECT 3 | db.name as database 4 | , count(distinct g.id) as games 5 | , count(distinct me.game_id) as games_evaluated 6 | , sum((me.id is not null)::Int) as number_evals 7 | FROM game g 8 | JOIN database db ON db.id=g.database_id 9 | LEFT JOIN move_eval me ON g.id=me.game_id 10 | GROUP BY db.name; 11 | -------------------------------------------------------------------------------- /src/AppTypes.hs: -------------------------------------------------------------------------------- 1 | module AppTypes where 2 | 3 | data AppType 4 | = Dev 5 | | Prod 6 | | Test 7 | deriving (Show) 8 | 9 | data Settings = Settings 10 | { appType :: AppType 11 | , showLogin :: Bool 12 | , appDBName :: String 13 | , appPort :: Int 14 | } deriving (Show) 15 | 16 | getSettings :: AppType -> Settings 17 | getSettings Dev = Settings Dev True (getDBName Dev) (getPortForApp Dev) 18 | getSettings Prod = Settings Prod True (getDBName Prod) (getPortForApp Prod) 19 | getSettings Test = Settings Test True (getDBName Test) (getPortForApp Test) 20 | 21 | getAppType :: String -> AppType 22 | getAppType "prod" = Prod 23 | getAppType "test" = Test 24 | getAppType _ = Dev 25 | 26 | getDBName :: AppType -> String 27 | getDBName Dev = "dev" 28 | getDBName Test = "test" 29 | getDBName Prod = "prod" 30 | 31 | getPortForApp :: AppType -> Int 32 | getPortForApp Dev = 8100 33 | getPortForApp Prod = 8001 34 | getPortForApp Test = 8102 35 | -------------------------------------------------------------------------------- /src/Application.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Application 6 | ( App 7 | , app 8 | , routes 9 | , auth 10 | , service 11 | , sess 12 | , resetUser 13 | ) where 14 | 15 | import AppTypes 16 | import Control.Lens (makeLenses, view) 17 | import Control.Monad (join, liftM3, when) 18 | import Control.Monad.IO.Class (liftIO) 19 | import Control.Monad.State.Class (get) 20 | import qualified Data.ByteString.Char8 as B (ByteString, pack, unpack) 21 | import Data.Map (Map) 22 | import qualified Data.Map as Map (lookup) 23 | import Data.Maybe (fromMaybe, listToMaybe) 24 | import qualified Data.Text as T (Text, pack, unpack) 25 | import Database.Persist.Sql (runMigrationUnsafe) 26 | import Debug.Trace (trace) 27 | import qualified Services.Service as S 28 | import Snap.Core 29 | ( Method(..) 30 | , getRequest 31 | , method 32 | , modifyResponse 33 | , redirect 34 | , rqParams 35 | , setResponseStatus 36 | , writeBS 37 | ) 38 | import Snap.Snaplet 39 | ( Handler 40 | , Snaplet 41 | , SnapletInit 42 | , addRoutes 43 | , makeSnaplet 44 | , nestSnaplet 45 | , snapletValue 46 | , subSnaplet 47 | , with 48 | , withTop 49 | ) 50 | import Snap.Snaplet.Auth 51 | ( AuthFailure 52 | , AuthManager(..) 53 | , AuthUser 54 | , clearPasswordResetToken 55 | , currentUser 56 | , loginUser 57 | , logout 58 | , lookupByLogin 59 | , registerUser 60 | , save 61 | , setPassword 62 | , setPasswordResetToken 63 | , userLogin 64 | , userResetToken 65 | ) 66 | import Snap.Snaplet.Auth.Backends.Persistent 67 | ( initPersistAuthManager 68 | , migrateAuth 69 | ) 70 | import Snap.Snaplet.Heist (HasHeist, Heist, heistInit, heistLens) 71 | import Snap.Snaplet.Persistent (PersistState, persistPool) 72 | import Snap.Snaplet.Session (SessionManager) 73 | import Snap.Snaplet.Session.Backends.CookieSession (initCookieSessionManager) 74 | 75 | data App = App 76 | { _heist :: Snaplet (Heist App) 77 | , _sess :: Snaplet SessionManager 78 | , _db :: Snaplet PersistState 79 | , _auth :: Snaplet (AuthManager App) 80 | , _service :: Snaplet (S.Service App) 81 | } 82 | 83 | makeLenses ''App 84 | 85 | instance HasHeist App where 86 | heistLens = subSnaplet heist 87 | 88 | app :: Settings -> SnapletInit App App 89 | app settings = 90 | makeSnaplet "app" "An snaplet example application." Nothing $ do 91 | let dbName = appDBName settings 92 | h <- nestSnaplet "" heist $ heistInit "templates" 93 | s <- 94 | nestSnaplet "sess" sess $ 95 | initCookieSessionManager "site_key.txt" "sess" Nothing (Just 3600) 96 | d <- 97 | nestSnaplet "db" db $ 98 | S.initPersistWithDB dbName (runMigrationUnsafe migrateAuth) 99 | a :: Snaplet (AuthManager App) <- 100 | nestSnaplet "auth" auth $ 101 | initPersistAuthManager sess (persistPool $ view snapletValue d) 102 | 103 | let user = view snapletValue a 104 | let login = T.unpack . userLogin <$> activeUser user 105 | 106 | serviceSnaplet <- nestSnaplet "api" service $ S.serviceInit dbName auth 107 | addRoutes $ routes $ showLogin settings 108 | return $ App h s d a serviceSnaplet 109 | 110 | routes :: Bool -> [(B.ByteString, Handler App App ())] 111 | routes False = [] 112 | routes True = routes False ++ loginRoutes 113 | 114 | loginRoutes :: [(B.ByteString, Handler App App ())] 115 | loginRoutes = 116 | [ ("login", with auth handleLoginSubmit) 117 | , ("register", with auth handleNewUser) 118 | , ("logout", with auth handleLogout >> resetUser) 119 | , ("resetPasswordData", with auth resetPasswordHandler) 120 | -- disabled until I think through how to avoid spamming 121 | -- , ("sendPasswordResetEmail", with auth sendPasswordResetHandler) 122 | ] 123 | 124 | writeLoginSuccess :: Handler b (AuthManager b) () 125 | writeLoginSuccess = do 126 | user <- currentUser 127 | let login = fmap (T.unpack . userLogin) user :: Maybe String 128 | modifyResponse $ setResponseStatus 200 "Success" 129 | writeBS $ B.pack $ fromMaybe "" login 130 | 131 | writeLoginFailure :: AuthFailure -> Handler b (AuthManager b) () 132 | writeLoginFailure failure = do 133 | modifyResponse $ setResponseStatus 403 "Login failed" 134 | writeBS $ B.pack $ show failure 135 | 136 | handleLoginSubmit :: Handler App (AuthManager App) () 137 | handleLoginSubmit = do 138 | loginUser "email" "password" Nothing writeLoginFailure writeLoginSuccess 139 | user <- currentUser 140 | let login = fmap (T.unpack . userLogin) user 141 | liftIO $ print $ "Changing user to" ++ show login 142 | return () 143 | 144 | resetUser :: Handler App App () 145 | resetUser = do 146 | withTop auth logout 147 | return () 148 | 149 | handleLogout :: Handler App (AuthManager App) () 150 | handleLogout = logout 151 | 152 | registerNew :: Handler App (AuthManager App) (Either AuthFailure AuthUser) 153 | registerNew = method POST $ registerUser "email" "password" 154 | 155 | handleNewUser :: Handler App (AuthManager App) () 156 | handleNewUser = do 157 | res <- registerNew 158 | -- Registering creates a `snap_auth_user` in the database. However, we 159 | -- also want to create an `app_user` that is linked to the `snap_auth_user`, 160 | -- because this allows us to assume a one-to-one relationship between 161 | -- the tables 162 | trace (show res) $ 163 | case res of 164 | Right authUser -> do 165 | let usId = userLogin authUser 166 | withTop service $ S.createAppUser usId 167 | handleLoginSubmit 168 | writeLoginSuccess 169 | Left authFail -> writeLoginFailure authFail 170 | 171 | -- Logic for resetting passwords. This works as follows: 172 | -- 1. A request is sent to '/sendPasswordResetEmail?email=example@example.com' 173 | -- 2. The backend creates a password reset token for the user 174 | -- 3. The backend sends out an email linking to 175 | -- '/resetpassword?email...&token=..." 176 | -- 4. The form collects a new password and submits it 177 | -- to "/resetPasswordData?email...&token=...&password=..." 178 | -- 5. The password is reset, the token for the user is destroyed 179 | -- 6. The server forwards to /passwordgood 180 | -- The endpoints "/resetpassword" and "/passwordgood" are not defined here 181 | -- but are automatically created from the corresponding heist templates. 182 | getProperty :: String -> Map B.ByteString [B.ByteString] -> Maybe T.Text 183 | getProperty name queryMap = 184 | fmap (T.pack . B.unpack) $ 185 | listToMaybe =<< Map.lookup (B.pack name) queryMap 186 | 187 | resetWithUser :: T.Text -> Handler b (AuthManager b) () 188 | resetWithUser login = do 189 | request <- getRequest 190 | let params = rqParams request 191 | let token = getProperty "token" params 192 | manager <- get 193 | let getUser AuthManager {backend = b} = lookupByLogin b login 194 | maybeUser <- liftIO $ getUser manager 195 | let newPass = getProperty "password" params 196 | let resetter = liftM3 (resetPassForUser manager) token maybeUser newPass 197 | fromMaybe (return ()) resetter 198 | clearPasswordResetToken login 199 | return () 200 | 201 | resetPassForUser :: 202 | AuthManager b 203 | -> T.Text 204 | -> AuthUser 205 | -> T.Text 206 | -> Handler b (AuthManager b) () 207 | resetPassForUser manager token user newPass = do 208 | let storedToken = userResetToken user 209 | when (storedToken == Just token) $ do 210 | updatedUser <- liftIO $ setPassword user $ B.pack $ T.unpack newPass 211 | liftIO $ save manager updatedUser 212 | let login = userLogin user 213 | clearPasswordResetToken login 214 | redirect "/snap_prod/passwordchangegood" 215 | 216 | resetPasswordHandler :: Handler b (AuthManager b) () 217 | resetPasswordHandler = do 218 | request <- getRequest 219 | let params = rqParams request 220 | let user = getProperty "email" params 221 | maybe (return ()) resetWithUser user 222 | return () 223 | 224 | sendPasswordResetHandler :: Handler b (AuthManager b) () 225 | sendPasswordResetHandler = do 226 | request <- getRequest 227 | let params = rqParams request 228 | let user = T.unpack <$> getProperty "email" params 229 | maybe (return ()) sendPasswordResetEmail user 230 | 231 | sendPasswordResetEmail :: String -> Handler b (AuthManager b) () 232 | sendPasswordResetEmail email = do 233 | token <- setPasswordResetToken (T.pack email) 234 | maybe (return ()) (sendEmailForToken email) token 235 | 236 | sendEmailForToken :: String -> T.Text -> Handler b (AuthManager b) () 237 | sendEmailForToken email token = do 238 | let url = "https://chessinsights.org/snap_prod/resetpassword?" 239 | let fullUrl = url ++ "email=" ++ email ++ "&token=" ++ T.unpack token 240 | let body = "Reset password link for chess insights \n " ++ fullUrl 241 | liftIO $ S.trySendEmail "Password reset for chessinsights.org" email body 242 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | import Control.Comonad 7 | import Control.Lens (view) 8 | import Control.Monad.IO.Class (liftIO) 9 | import Control.Monad.State 10 | import qualified Data.ByteString.Char8 as B 11 | import Data.Either 12 | import Data.IORef 13 | import Data.Maybe 14 | import qualified Services.Service as S 15 | import Snap.Http.Server 16 | import Snap.Snaplet 17 | import Snap.Snaplet.Config 18 | import Snap.Snaplet.PostgresqlSimple 19 | import System.Environment (lookupEnv) 20 | 21 | import AppTypes 22 | import Application 23 | 24 | readSettings :: IO Settings 25 | readSettings = do 26 | appTypeEnv :: Maybe String <- liftIO $ lookupEnv "type" 27 | let appType_ = maybe Dev getAppType appTypeEnv 28 | return $ getSettings appType_ 29 | 30 | main :: IO () 31 | main = do 32 | settings <- readSettings 33 | print settings 34 | let config = setErrorLog (ConfigFileLog "error.txt") $ setAccessLog (ConfigFileLog "log.txt") $ setPort (appPort settings) defaultConfig 35 | serveSnaplet config $ app settings 36 | 37 | -------------------------------------------------------------------------------- /src/Services/DatabaseHelpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE DataKinds #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | 11 | module Services.DatabaseHelpers where 12 | 13 | import Control.Monad.Reader (MonadIO, join, liftIO) 14 | import Data.Attoparsec.Text (Parser, char, digit, many', parseOnly) 15 | import Data.Either (rights) 16 | import Data.Either.Combinators (rightToMaybe) 17 | import Data.List (intercalate) 18 | import Data.List.Split (chunksOf) 19 | import Data.Foldable (find) 20 | import Data.Maybe (fromJust, isJust, listToMaybe) 21 | import Text.Printf (printf) 22 | import qualified Data.Text as Te (Text, pack, intercalate) 23 | import qualified Data.Text.IO as TeIO (writeFile) 24 | import Data.Time (Day, fromGregorian) 25 | import qualified Filesystem.Path.CurrentOS as FS (fromText) 26 | import qualified Turtle as Tu (input, strict, Text) 27 | import Database.Persist 28 | ( Entity 29 | , Key 30 | , (=.) 31 | , (==.) 32 | , entityKey 33 | , entityVal 34 | , insert 35 | , insertBy 36 | , selectList 37 | , update 38 | ) 39 | import Database.Persist.Postgresql (transactionSave) 40 | import Debug.Trace (trace) 41 | 42 | import qualified Chess.Pgn.Logic as Pgn 43 | import qualified Chess.Helpers as Helpers 44 | 45 | import Test.Helpers as Helpers 46 | import Services.Types 47 | import Services.Openings (OpeningMap, opVariation, getOpening, getOpeningData) 48 | 49 | 50 | connString :: String -> String 51 | connString dbName = trace name name 52 | where 53 | name = "host=localhost dbname=chess_" ++ dbName ++ " user=postgres" 54 | 55 | keyReader :: forall record. Either (Entity record) (Key record) -> Key record 56 | keyReader = either entityKey id 57 | 58 | -- It can happen that a game doesn't have an opening, and that 59 | -- with improved algorithms, we can now find an opening. Thus we want a function 60 | -- that updates the opening of all games without openings. 61 | addOpeningsToGames :: DataAction () 62 | addOpeningsToGames = do 63 | openings <- getOpeningData 64 | gamesWithoutOpening :: [Entity Game] <- selectList [GameOpeningVariation ==. Nothing] [] 65 | liftIO $ print $ "Games without: " ++ show (length gamesWithoutOpening) 66 | mapM_ (addOpeningToGame openings) gamesWithoutOpening 67 | 68 | addOpeningToGame :: OpeningMap -> Entity Game -> DataAction () 69 | addOpeningToGame openings entityGame = do 70 | let key = entityKey entityGame 71 | let pgnGame = Pgn.readSingleGame $ Te.pack $ gamePgn $ entityVal entityGame 72 | either (const (return ())) (openingHelper openings key) pgnGame 73 | 74 | openingHelper :: OpeningMap -> Key Game -> Pgn.PgnGame -> DataAction () 75 | openingHelper openings key pgnGame = do 76 | let game = Pgn.parsedPgnGame pgnGame :: Pgn.Game 77 | let opening = entityKey . opVariation <$> getOpening openings game 78 | update key [GameOpeningVariation =. opening] 79 | return () 80 | 81 | storeGameIntoDB :: 82 | Key Database -> OpeningMap -> Pgn.PgnGame -> DataAction (Maybe (Key Game)) 83 | storeGameIntoDB dbResult openings g = do 84 | let game = Pgn.parsedPgnGame g 85 | let opening = entityKey . opVariation <$> getOpening openings game 86 | let pgn = Pgn.gamePgnFull game 87 | let tags = Pgn.pgnGameTags g :: [Pgn.PgnTag] 88 | let requiredTags = trace (show tags) $ parseRequiredTags tags 89 | if isJust requiredTags 90 | then do 91 | let parsedTags = fromJust requiredTags 92 | (playerWhite, playerBlack) <- storePlayers dbResult parsedTags 93 | tournament <- storeTournament dbResult parsedTags 94 | let resultInt = resultDBFormat $ requiredResult parsedTags 95 | let date = getDate tags -- Maybe Day 96 | -- Storing the game 97 | let gm = Game dbResult playerWhite playerBlack resultInt tournament pgn date opening 98 | gameResult <- keyReader <$> insertBy gm 99 | -- Storing the tags 100 | let formattedTags = formatForDB <$> filter (not . isPlayer) tags 101 | mapM_ (\(name, v) -> insert (GameAttribute gameResult name v)) formattedTags 102 | return $ Just gameResult 103 | else do 104 | liftIO $ print $ show g 105 | return Nothing 106 | 107 | 108 | storeTournament :: Key Database -> RequiredTags -> DataAction (Key Tournament) 109 | storeTournament dbResult tags = do 110 | let (Pgn.PgnEvent eventName) = requiredEvent tags 111 | result <- insertBy $ Tournament dbResult eventName 112 | return $ keyReader result 113 | 114 | 115 | storePlayers :: Key Database -> RequiredTags -> DataAction (Key Player, Key Player) 116 | storePlayers dbResult tags = do 117 | let (whitePlayer, blackPlayer) = (requiredWhitePlayer tags, requiredBlackPlayer tags) 118 | let (Pgn.PgnWhite (Pgn.Player firstWhite lastWhite)) = whitePlayer 119 | let (Pgn.PgnBlack (Pgn.Player firstBlack lastBlack)) = blackPlayer 120 | whiteResult <- insertBy (Player dbResult firstWhite lastWhite) 121 | blackResult <- insertBy (Player dbResult firstBlack lastBlack) 122 | return (keyReader whiteResult, keyReader blackResult) 123 | 124 | 125 | data RequiredTags = RequiredTags { 126 | requiredWhitePlayer :: Pgn.PgnTag 127 | , requiredBlackPlayer :: Pgn.PgnTag 128 | , requiredResult :: Pgn.PgnTag 129 | , requiredEvent :: Pgn.PgnTag} 130 | 131 | parseRequiredTags :: [Pgn.PgnTag] -> Maybe RequiredTags 132 | parseRequiredTags tags = 133 | RequiredTags <$> maybeWhite <*> maybeBlack <*> maybeResult <*> maybeEvent 134 | where 135 | maybeWhite = Helpers.safeHead $ filter filterWhitePlayer tags 136 | maybeBlack = Helpers.safeHead $ filter filterBlackPlayer tags 137 | maybeResult = Helpers.safeHead $ filter filterResult tags 138 | maybeEvent = Helpers.safeHead $ filter filterEvent tags 139 | 140 | isPlayer :: Pgn.PgnTag -> Bool 141 | isPlayer (Pgn.PgnWhite _) = True 142 | isPlayer (Pgn.PgnBlack _) = True 143 | isPlayer _ = False 144 | 145 | filterWhitePlayer :: Pgn.PgnTag -> Bool 146 | filterWhitePlayer (Pgn.PgnWhite _) = True 147 | filterWhitePlayer _ = False 148 | 149 | filterBlackPlayer :: Pgn.PgnTag -> Bool 150 | filterBlackPlayer (Pgn.PgnBlack _) = True 151 | filterBlackPlayer _ = False 152 | 153 | filterResult :: Pgn.PgnTag -> Bool 154 | filterResult (Pgn.PgnResult _) = True 155 | filterResult _ = False 156 | 157 | filterEvent :: Pgn.PgnTag -> Bool 158 | filterEvent (Pgn.PgnEvent _) = True 159 | filterEvent _ = False 160 | 161 | filterDate :: Pgn.PgnTag -> Bool 162 | filterDate (Pgn.PgnDate _) = True 163 | filterDate _ = False 164 | 165 | 166 | resultDBFormat :: Pgn.PgnTag -> Int 167 | resultDBFormat (Pgn.PgnResult Pgn.WhiteWin) = 1 168 | resultDBFormat (Pgn.PgnResult Pgn.BlackWin) = -1 169 | resultDBFormat (Pgn.PgnResult Pgn.Draw) = 0 170 | resultDBFormat _ = 0 171 | 172 | getDate :: [Pgn.PgnTag] -> Maybe Day 173 | getDate tags = extractParse =<< find filterDate tags 174 | where extractParse (Pgn.PgnDate d) = rightToMaybe $ parseOnly dateStringParse (Te.pack d) 175 | 176 | dateStringParse :: Parser Day 177 | dateStringParse = do 178 | year <- many' digit 179 | char '.' 180 | month <- many' digit 181 | char '.' 182 | day <- many' digit 183 | return $ fromGregorian (read year :: Integer) (read month :: Int) (read day :: Int) 184 | 185 | writeChunk :: String -> Int -> [Te.Text] -> IO () 186 | writeChunk fileName fileNumber texts = do 187 | let fullName = fileName ++ "_" ++ printf "%05d" fileNumber ++ ".pgn" 188 | TeIO.writeFile fullName $ Te.intercalate (Te.pack "\n") texts 189 | 190 | 191 | splittingHelper :: String -> Int -> IO () 192 | splittingHelper fileName number = do 193 | fileText <- Tu.strict $ Tu.input $ FS.fromText $ Te.pack fileName 194 | 195 | let splits = Pgn.splitIntoGames fileText 196 | let chunks = zip [0..] $ chunksOf number splits 197 | 198 | mapM_ (uncurry (writeChunk fileName)) chunks 199 | 200 | 201 | 202 | 203 | readTextIntoDB :: 204 | MonadIO m 205 | => String 206 | -> String 207 | -> Te.Text 208 | -> Bool 209 | -> Maybe String 210 | -> m (Key Database, [Maybe (Key Game)]) 211 | readTextIntoDB dbName chessDBName text isPublic user = 212 | liftIO $ inBackend (connString dbName) $ readTextWithPersist chessDBName text isPublic user 213 | 214 | readTextWithPersist :: 215 | String -> Tu.Text -> Bool -> Maybe String -> DataAction (Key Database, [Maybe (Key Game)]) 216 | readTextWithPersist chessDBName text isPublic user = do 217 | dbResult <- insertBy (Database chessDBName isPublic user) 218 | transactionSave 219 | let dbKey = keyReader dbResult 220 | 221 | -- Lazily parse and enter games into db 222 | let games = Pgn.getGamesFromText text 223 | openings <- getOpeningData 224 | 225 | 226 | 227 | 228 | 229 | gameResults <- mapM (storeGameIntoDB dbKey openings) $ rights games 230 | transactionSave 231 | return (dbKey, gameResults) 232 | 233 | 234 | 235 | listToInClause :: [Int] -> String 236 | listToInClause ints = clause 237 | where intStrings = fmap show ints :: [String] 238 | clause = '(' : intercalate ", " intStrings ++ ")" 239 | -------------------------------------------------------------------------------- /src/Services/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE DataKinds #-} 8 | {-# LANGUAGE DeriveGeneric #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | 12 | module Services.Helpers where 13 | 14 | import Control.Lens ((^.), _1, _2, _3, to) 15 | import Control.Monad (join) 16 | import Data.Aeson.Types 17 | ( ToJSON 18 | , defaultOptions 19 | , fieldLabelModifier 20 | , genericToJSON 21 | , toJSON 22 | ) 23 | import Data.Char (toLower) 24 | import Data.List (groupBy, sortOn) 25 | import qualified Data.List.Safe as Safe (head) 26 | import Data.Map (Map, assocs, elems, fromList, lookup, mapKeys, mapWithKey) 27 | import Data.Maybe (catMaybes, fromJust, fromMaybe) 28 | import Database.Persist (PersistEntity, PersistValue(PersistInt64), keyToValues) 29 | import Database.Persist.Postgresql (Entity, Key, entityKey, entityVal, toSqlKey) 30 | import GHC.Generics (Generic) 31 | import Prelude hiding (lookup) 32 | 33 | import Services.StatsHelpers 34 | import Services.Types 35 | 36 | type EntityMap a = Map (Key a) a 37 | 38 | type DataForMoveAverage = (GameResult, IsWhite, MoveEval) 39 | 40 | data GameResult 41 | = Win 42 | | Draw 43 | | Lose 44 | deriving (Eq, Show) 45 | 46 | type EvalResult = (Entity MoveEval, Entity Game) 47 | 48 | type MoveNumber = Int 49 | type EvalInt = Int 50 | 51 | -- |Taking a list of move evaluations and, if it has less then the desired number 52 | -- of elements, padding it at the end. The padded value is the eveluation corresponding 53 | -- to the game result. 54 | padEvals :: Int -> GameResult -> [(MoveNumber, EvalInt)] -> [(MoveNumber, EvalInt)] 55 | padEvals desiredLength result vals 56 | | length vals >= desiredLength = vals 57 | | otherwise = vals ++ zipped 58 | where 59 | zipped = zip [(length vals + 1) .. desiredLength] (repeat (resultValue result)) 60 | 61 | invertGameResult :: GameResult -> GameResult 62 | invertGameResult Win = Lose 63 | invertGameResult Lose = Win 64 | invertGameResult Draw = Draw 65 | 66 | getOwnGameResult :: GameResult -> IsWhite -> GameResult 67 | getOwnGameResult gameResult True = gameResult 68 | getOwnGameResult gameResult False = invertGameResult gameResult 69 | 70 | 71 | moveAverage :: EntityMap Player -> Key Player -> [DataForMoveAverage] -> MoveSummary 72 | moveAverage playerMap playerKey me = MoveSummary key playerName average 73 | where average = MoveAverage $ averageByPlayer me 74 | player = fromJust $ lookup playerKey playerMap 75 | key = show playerKey 76 | playerName = show player 77 | 78 | 79 | -- |Given the move evaluations, return the average evaluation for each player. 80 | averageByPlayer :: [DataForMoveAverage] -> MoveAverageData 81 | averageByPlayer dataForAverage = fmap calculateStats evals 82 | where mapByGame = groupWithVal (moveEvalGameId . (^. _3)) dataForAverage -- Map (Key Game) [DataForMoveAverage] 83 | maxLength = maximum $ length <$> elems mapByGame 84 | mapWithMove = fmap (aggregateEval maxLength) mapByGame -- Map (Key Game) [(Int, Int)] 85 | evals = (fmap . fmap) snd $ groupWithVal fst $ concat mapWithMove -- Map Int [Int] 86 | calculateStats x = (intAverage x, (stdError . fmap fromIntegral) x) 87 | 88 | aggregateEval :: Int -> [DataForMoveAverage] -> [(Int, Int)] 89 | aggregateEval maxLength dataForAverage = maybe [] (\r -> padEvals maxLength r (zip moves evals)) result 90 | where vals = fmap (\(_, isW, me) -> (isW, me)) dataForAverage -- [(IsWhite, MoveEval)] 91 | result = (^. _1) <$> Safe.head dataForAverage 92 | evals = fmap (uncurry evalAsIntWithColor) vals 93 | moves = fmap (^.(_2 . to moveEvalMoveNumber)) vals 94 | 95 | entityToMap :: Ord (Key a) => [Entity a] -> Map (Key a) a 96 | entityToMap ls = fromList [(entityKey x, entityVal x) | x <- ls] 97 | 98 | maxEval :: Int 99 | maxEval = 400 100 | 101 | resultValue :: GameResult -> Int 102 | resultValue Win = maxEval 103 | resultValue Lose = - maxEval 104 | resultValue Draw = 0 105 | 106 | readGameResult :: Int -> Maybe GameResult 107 | readGameResult 1 = Just Win 108 | readGameResult 0 = Just Draw 109 | readGameResult (-1) = Just Lose 110 | readGameResult _ = Nothing 111 | 112 | evalAsIntWithColor :: Bool -> MoveEval -> Int 113 | evalAsIntWithColor True me = evalAsInt me 114 | evalAsIntWithColor False me = - (evalAsInt me) 115 | 116 | -- |Obtain a single number from a move evaluation, combining mates and non-mates. 117 | -- The first step is to multiply all mates by a huge number, this ensures 118 | -- that mates are always seen as better than non-mates. We then 119 | -- top-code and bottom-code the results. 120 | 121 | -- Todo: This should never happen, figure out why 122 | errorEval :: Int 123 | errorEval = 0 124 | 125 | evalAsInt :: MoveEval -> Int 126 | evalAsInt me = max (- maxEval) (min maxEval eval) 127 | where eval = fromMaybe errorEval singleNumber 128 | mateMultiplier = 100 129 | singleNumber = join $ Safe.head [moveEvalEval me, fmap (*mateMultiplier) (moveEvalMate me)] 130 | 131 | -- Grouping a list based on a function on the list elements. 132 | -- The `head` is safe here because it's only run on lists with at least one 133 | -- element. This still feels hacky, but at least it's safe. 134 | groupWithVal :: (Ord b) => (a -> b) -> [a] -> Map b [a] 135 | groupWithVal f x = fromList [(fst (head el), fmap snd el) | el <- grouped, not (null el)] 136 | where tuples = [(f val, val) | val <- sortOn f x] 137 | equal t t' = fst t == fst t' 138 | grouped = groupBy equal tuples -- [[(b, a)]] 139 | 140 | addColor :: Key Player -> [EvalResult] -> [(GameResult, IsWhite, EvalResult)] 141 | addColor player evalResults = [(ownGameResult g, isWhite g, evalResult) | evalResult@(_, g) <- evalResults] 142 | where isWhite g = gamePlayerWhiteId (entityVal g) == player 143 | results g = readGameResult $ gameGameResult $ entityVal g 144 | gameResult g = fromJust $ results g 145 | ownGameResult g = getOwnGameResult (gameResult g) (isWhite g) 146 | 147 | playerBlack :: Entity MoveEval -> Entity Game -> Key Player 148 | playerBlack _ gm = gamePlayerBlackId $ entityVal gm 149 | 150 | playerNotToMove :: Entity MoveEval -> Entity Game -> Key Player 151 | playerNotToMove me gm = if moveEvalIsWhite m then gamePlayerBlackId g else gamePlayerWhiteId g 152 | where m = entityVal me 153 | g = entityVal gm 154 | 155 | -- Only keep the evaluations that have the other person to move 156 | -- That provides the evaluations of the moves the player made. 157 | movesByPlayer :: [EvalResult] -> Map (Key Player) [DataForMoveAverage] 158 | movesByPlayer res = (fmap . fmap) keepRelevant groupedWithColor 159 | where grouped = groupWithVal (uncurry playerNotToMove) res -- Map (Key Player) [EvalResult] 160 | groupedWithColor = mapWithKey addColor grouped -- Map (Key Player) [DataForMoveAverage] 161 | keepRelevant (gr, isWhite, (me, _)) = (gr, isWhite, entityVal me) 162 | 163 | data MoveSummary = MoveSummary { 164 | moveSummaryKey :: String 165 | , moveSummaryPlayer :: String 166 | , moveSummaryEvaluations :: MoveAverage } deriving (Generic) 167 | 168 | instance ToJSON MoveSummary where 169 | toJSON = genericToJSON defaultOptions { fieldLabelModifier = cleanSummName } 170 | 171 | cleanSummName :: String -> String 172 | cleanSummName s = toLower c : rest 173 | where (c: rest) = drop (length ("moveSummary" :: String)) s 174 | 175 | type AvgMoveEval = Int 176 | type AvgMoveStdError = Float 177 | 178 | type MoveAverageData = Map MoveNumber (AvgMoveEval, AvgMoveStdError) 179 | newtype MoveAverage = MoveAverage MoveAverageData 180 | 181 | instance ToJSON MoveAverage where 182 | toJSON (MoveAverage ma) = toJSON $ mapKeys show ma 183 | 184 | summarizeEvals :: [Entity Player] -> [EvalResult] -> [MoveSummary] 185 | summarizeEvals players evals = handleMoveAverage playerMap <$> assocs byPlayer 186 | where byPlayer = movesByPlayer evals 187 | playerMap = entityToMap players 188 | 189 | handleMoveAverage :: Map (Key Player) Player -> (Key Player, [DataForMoveAverage]) -> MoveSummary 190 | handleMoveAverage playerMap (playerKey, list) = moveAverage playerMap playerKey list 191 | 192 | summarizeByPlayer :: a -> [EvalResult] -> [(Key Player, [DataForMoveAverage])] 193 | summarizeByPlayer _ evals = list 194 | where list = assocs $ movesByPlayer evals 195 | 196 | type IsWhite = Bool 197 | 198 | dbKey :: PersistEntity a => Entity a -> Int 199 | dbKey ent = dbKeyInt $ entityKey ent 200 | 201 | dbKeyInt :: PersistEntity a => Key a -> Int 202 | dbKeyInt key = head $ catMaybes $ keyInt <$> keyToValues key 203 | 204 | keyInt :: PersistValue -> Maybe Int 205 | keyInt (PersistInt64 a) = Just $ fromIntegral a 206 | keyInt _ = Nothing 207 | 208 | intToKey :: Int -> Key Tournament 209 | intToKey = toSqlKey . fromIntegral 210 | 211 | intToKeyDB :: Int -> Key Database 212 | intToKeyDB = toSqlKey . fromIntegral 213 | 214 | intToKeyGame :: Int -> Key Game 215 | intToKeyGame = toSqlKey . fromIntegral 216 | 217 | -------------------------------------------------------------------------------- /src/Services/Openings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Services.Openings where 6 | 7 | import Data.Attoparsec.Combinator (many', many1') 8 | import Data.Attoparsec.Text 9 | ( Parser 10 | , anyChar 11 | , char 12 | , digit 13 | , endOfLine 14 | , letter 15 | , manyTill 16 | , parseOnly 17 | , skipWhile 18 | , space 19 | , string 20 | ) 21 | import Database.Persist (Key, insertBy) 22 | import Database.Persist.Sql (Filter) 23 | import Prelude hiding (lookup) 24 | 25 | import Data.Either.Combinators (rightToMaybe) 26 | import Data.Foldable (fold, find) 27 | import qualified Data.List.Split as LS (splitOn) 28 | import Data.Map (Map, fromList, lookup) 29 | import Data.Maybe (catMaybes, listToMaybe, mapMaybe) 30 | import Data.Text (Text, pack, splitOn, unpack) 31 | import Database.Esqueleto hiding (get) 32 | import Filesystem.Path.CurrentOS (fromText) 33 | import Services.Types 34 | import Turtle (input, strict) 35 | 36 | import qualified Chess.Fen as Fen 37 | import qualified Chess.Logic as ChessLogic 38 | import qualified Chess.Pgn.Logic as Pgn 39 | import Debug.Trace (trace) 40 | import Test.Helpers 41 | 42 | -- Todo: Remove this duplication 43 | connString :: String -> String 44 | connString dbName = trace name name 45 | where 46 | name = "host=localhost dbname=chess_" ++ dbName ++ " user=postgres" 47 | 48 | keyReader :: forall record. Either (Entity record) (Key record) -> Key record 49 | keyReader = either entityKey id 50 | 51 | data FullOpeningData = FullOpeningData { 52 | opMajor :: Entity OpeningLine 53 | , opVariation :: Entity OpeningVariation 54 | , opCode :: Entity OpeningCode 55 | } 56 | 57 | type Fen = String 58 | type OpeningMap = Map Fen FullOpeningData 59 | 60 | 61 | parseOpenings :: Text -> [ListData] 62 | parseOpenings text = mapMaybe (rightToMaybe . parseOnly parseListData) split 63 | where split = splitOn "\r\n\r" text 64 | 65 | deleteOpenings :: DataAction () 66 | deleteOpenings = do 67 | rawExecute "UPDATE game set opening_variation=null" [] 68 | 69 | deleteWhere ([] :: [Filter OpeningVariation]) 70 | deleteWhere ([] :: [Filter OpeningLine]) 71 | deleteWhere ([] :: [Filter OpeningCode]) 72 | 73 | storeOpenings :: String -> IO () 74 | storeOpenings dbName = do 75 | text :: Text <- strict $ input $ fromText $ pack "./data/openings.txt" 76 | let actionRunner = inBackend (connString dbName) 77 | let storeIO dat = actionRunner $ tryStoreOpening dat 78 | actionRunner deleteOpenings 79 | mapM_ storeIO $ parseOpenings text 80 | 81 | -- |Reads the opening data from the database and returns it as a `Map` 82 | -- that makes it easy to obtain the opening corresponding to a game. 83 | getOpeningData :: DataAction OpeningMap 84 | getOpeningData = do 85 | variations :: [(Entity OpeningLine, Entity OpeningVariation, Entity OpeningCode)] <- 86 | select $ 87 | from $ \(l, v, c) -> do 88 | where_ $ 89 | (v ^. OpeningVariationCode ==. c ^. OpeningCodeId) &&. 90 | (v ^. OpeningVariationLine ==. l ^. OpeningLineId) 91 | return (l, v, c) 92 | let list = 93 | [ (openingVariationFen (entityVal v), FullOpeningData l v c) 94 | | (l, v, c) <- variations 95 | ] 96 | return $ fromList list 97 | 98 | parseVariation :: String -> Maybe (String, String) 99 | parseVariation variationName = getVariation $ LS.splitOn ":" variationName 100 | 101 | getVariation :: [String] -> Maybe (String, String) 102 | getVariation [] = Nothing 103 | getVariation [a] = Just (simplifyLine a, "") 104 | getVariation [a,b] = Just (simplifyLine a, b) 105 | getVariation _ = Nothing 106 | 107 | -- The original opening names involve duplicates (e.g. 108 | -- both Pirc Defense and Pirc). Removing those duplicates 109 | -- wherever I spot them. 110 | simplifyLine :: String -> String 111 | simplifyLine line = maybe line snd maybeReplaced 112 | where maybeReplaced = find ((== line) . fst) lineRenames 113 | 114 | lineRenames :: [(String, String)] 115 | lineRenames = 116 | [ ("Polish Opening", "Polish") 117 | , ("Grob's Attack", "Grob") 118 | , ("Reti Opening", "Reti") 119 | , ("Old Indian Defense", "Old Indian") 120 | , ("Old Benoni Defense", "Old Benoni") 121 | , ("Czech Benoni Defense", "Czech Benoni") 122 | , ("Scandinavian Defense", "Scandinavian") 123 | , ("Pirc Defense", "Pirc") 124 | , ("English Opening", "English") 125 | , ("English Opening (e4)", "English") 126 | , ("Budapest Defense Declined", "Budapest Defense") 127 | , ("Sicilian Defense", "Sicilian") 128 | ] 129 | 130 | storeOpening :: String -> String -> String -> Pgn.PgnGame -> DataAction () 131 | storeOpening code variationName standardMoves game = do 132 | let line = parseVariation variationName 133 | maybe (return ()) (uncurry (storeWithFullData code standardMoves game)) line 134 | 135 | storeWithFullData :: String -> String -> Pgn.PgnGame -> String -> String -> DataAction () 136 | storeWithFullData code standardMoves game majorLine variation = do 137 | lineKey :: Key OpeningLine <- keyReader <$> insertBy (OpeningLine majorLine) 138 | codeKey :: Key OpeningCode <- keyReader <$> insertBy (OpeningCode code) 139 | let fen = Fen.gameStateToFen $ last $ Pgn.gameStates $ Pgn.parsedPgnGame game 140 | insertBy $ OpeningVariation variation fen standardMoves codeKey lineKey 141 | return () 142 | 143 | tryStoreOpening :: ListData -> DataAction () 144 | tryStoreOpening (ListData code variationName standardMoves) = do 145 | let game = Pgn.readSingleGame $ pack standardMoves 146 | either (\_ -> return ()) (storeOpening code variationName standardMoves) game 147 | 148 | getOpening :: OpeningMap -> ChessLogic.Game -> Maybe FullOpeningData 149 | getOpening mp game = listToMaybe $ catMaybes sortedMatches 150 | where sortedMatches = reverse $ flip lookup mp <$> initialFens 151 | initialFens = take 10 $ Fen.gameStateToFen <$> Pgn.gameStates game 152 | 153 | type OpenName = String 154 | type CodeName = String 155 | type OpenMoves = String 156 | 157 | data ListData = ListData 158 | { openCode :: CodeName 159 | , openName :: OpenName 160 | , openMoves :: OpenMoves 161 | } deriving (Eq, Show) 162 | 163 | parseListData :: Parser ListData 164 | parseListData = do 165 | many' endOfLine 166 | code :: CodeName <- openingCodeParser 167 | many1' space 168 | name :: String <- openingNameParser 169 | many1' endOfLine 170 | ListData code name <$> openMoveParser 171 | 172 | openingNameParser :: Parser String 173 | openingNameParser = do 174 | name <- many1' $ fold $ [letter, digit] ++ fmap char (" /-:()\'" ++ ['.', '/']) 175 | many' $ char ';' 176 | skipWhile (\c -> c `notElem` ("\n\r" :: String)) 177 | return name 178 | 179 | openingCodeParser :: Parser CodeName 180 | openingCodeParser = many1' $ fold $ digit : fmap char (['A'..'E'] ++ ['/']) 181 | 182 | openMoveParser :: Parser OpenMoves 183 | openMoveParser = do 184 | start :: Text <- string "1." 185 | rest :: String <- manyTill anyChar (char '/') 186 | many' endOfLine 187 | let endPart = " 1" :: String 188 | let restCleaned = take (length rest - length endPart) rest 189 | return $ unpack start ++ restCleaned 190 | -------------------------------------------------------------------------------- /src/Services/Service.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE EmptyDataDecls #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE QuasiQuotes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE PartialTypeSignatures #-} 17 | 18 | module Services.Service where 19 | 20 | import Control.Lens (_1, makeLenses, over, _head, _tail, each) 21 | import qualified Control.Lens as Lens ((^.)) 22 | import Control.Exception (Exception, SomeException, throw) 23 | import Control.Monad.State.Class (get, gets) 24 | import Data.Char (toLower) 25 | import Data.Aeson (FromJSON, ToJSON, toJSON, eitherDecode, encode, genericToJSON, defaultOptions) 26 | import Data.Aeson.Types (fieldLabelModifier) 27 | import qualified Data.ByteString.Char8 as B (ByteString, pack) 28 | import Data.List (groupBy, intercalate) 29 | import qualified Data.Text as T (Text, length, pack, unpack) 30 | import qualified Data.Text.Lazy as LT (pack) 31 | import Database.Esqueleto hiding (get) 32 | import Database.Persist (insert, insert_) 33 | import qualified Database.Persist.Postgresql as PsP (entityVal, get, getBy) 34 | import Database.Persist.Sql (rawSql) 35 | import GHC.Generics (Generic) 36 | import Snap.Core (modifyResponse, setResponseStatus) 37 | import Snap.Snaplet 38 | ( Handler 39 | , MonadSnaplet 40 | , Snaplet 41 | , SnapletLens 42 | , SnapletInit 43 | , addRoutes 44 | , getSnapletUserConfig 45 | , makeSnaplet 46 | , nestSnaplet 47 | , with 48 | , withTop 49 | ) 50 | import Snap.Snaplet.PostgresqlSimple 51 | ( HasPostgres 52 | , Postgres 53 | , getPostgresState 54 | , pgsInit 55 | , setLocalPostgresState 56 | ) 57 | import System.Environment (lookupEnv) 58 | 59 | import Snap.Snaplet.Auth 60 | ( userLogin 61 | , currentUser 62 | , createUser 63 | , forceLogin 64 | , logout 65 | , withBackend 66 | , AuthUser(..) 67 | , UserId(..) 68 | , IAuthBackend(..) 69 | , AuthManager(..)) 70 | 71 | import Control.Concurrent 72 | ( MVar 73 | , forkIO 74 | , newMVar 75 | , putMVar 76 | , takeMVar 77 | , threadDelay 78 | ) 79 | import Control.Monad (liftM2, when, unless) 80 | import Control.Monad.IO.Class (MonadIO, liftIO) 81 | import qualified Data.Map as MP 82 | import Data.Maybe (fromMaybe, isJust, listToMaybe, catMaybes) 83 | import Data.Proxy (Proxy(..)) 84 | import Data.Time.Clock (getCurrentTime) 85 | import Servant (Server, serveSnap) 86 | import Servant.API hiding (GET) 87 | import Snap.Snaplet.Persistent 88 | ( HasPersistPool 89 | , PersistState 90 | , getPersistPool 91 | , initPersistGeneric 92 | , runPersist 93 | ) 94 | 95 | import Network.HTTP.Client (Manager) 96 | import Network.HTTP.Client.TLS (getGlobalManager) 97 | import Network.Mail.Mime (Address(..), simpleMail') 98 | import Network.Mail.Mime.SES (SES(..), renderSendMailSES, usEast1) 99 | 100 | import Control.Monad.Logger (NoLoggingT, runNoLoggingT) 101 | import qualified Data.Configurator as DC (lookup) 102 | import qualified Database.Persist.Postgresql as PG 103 | 104 | import Services.DatabaseHelpers (connString, readTextIntoDB) 105 | import Services.Helpers 106 | ( EvalResult 107 | , MoveSummary 108 | , dbKey 109 | , dbKeyInt 110 | , groupWithVal 111 | , intToKey 112 | , intToKeyDB 113 | , intToKeyGame 114 | , summarizeEvals 115 | ) 116 | import Services.Sql 117 | import Services.Tasks 118 | import Services.Types 119 | import qualified Test.Fixtures as TF 120 | import qualified Test.Helpers as TH 121 | 122 | import qualified Data.ByteString.Lazy as LBS 123 | import Data.Text.Encoding 124 | data Service b = Service { 125 | _servicePG :: Snaplet Postgres 126 | , _serviceDB :: Snaplet PersistState 127 | , _serviceAllTasks :: MVar AllTasks 128 | , _serviceAuth :: SnapletLens b (AuthManager b) 129 | } 130 | makeLenses ''Service 131 | 132 | type (Encoded a) = QueryParam "data" (JSONEncoded a) 133 | 134 | -- |The module boils down to this api. 135 | type ChessApi m = 136 | "user" :> Get '[JSON] (Maybe AppUser) :<|> 137 | "players" :> Encoded DefaultSearchData :> Get '[JSON] [Entity Player] :<|> 138 | "tournaments" :> Encoded DefaultSearchData :> Get '[JSON] [Entity Tournament] :<|> 139 | "databases" :> Get '[JSON] [Entity Database] :<|> 140 | "databaseStats" :> Get '[JSON] [DBResultFull] :<|> 141 | "evalResults" :> Encoded GameRequestData :> Get '[JSON] [EvalResult] :<|> 142 | "moveSummary" :> Encoded GameRequestData :> Get '[JSON] [MoveSummary] :<|> 143 | "dataSummary" :> Encoded DefaultSearchData :> Get '[JSON] DataSummary :<|> 144 | "resultPercentages" :> Encoded DefaultSearchData :> Get '[JSON] [ResultPercentage] :<|> 145 | "games" :> Encoded GameRequestData :> Get '[JSON] [GameDataFormatted] :<|> 146 | "gameEvaluations" :> Encoded GameRequestData :> Get '[JSON] PlayerGameEvaluations :<|> 147 | "moveEvaluations" :> Encoded GameRequestData :> Get '[JSON] [MoveEvaluationData] :<|> 148 | "moveEvaluationsFromIds" :> Encoded Ids :> Get '[JSON] [MoveEvaluationData] :<|> 149 | "uploadDB" :> ReqBody '[JSON] UploadData :> Post '[JSON] UploadResult :<|> 150 | "addEvaluations" :> ReqBody '[JSON] EvaluationRequest :> Post '[JSON] () :<|> 151 | "sendFeedback" :> ReqBody '[JSON] FeedbackData :> Post '[JSON] () 152 | 153 | chessApi :: Proxy (ChessApi (Handler b (Service b))) 154 | chessApi = Proxy 155 | 156 | -- apiServer :: Server (ChessApi (Handler b (Service b))) (Handler b (Service b)) 157 | apiServer = 158 | getMyUser :<|> 159 | validatedHandler getPlayers :<|> 160 | validatedHandler getTournaments :<|> 161 | getDatabases :<|> 162 | getDatabaseStats :<|> 163 | validatedHandler getEvalResults :<|> 164 | validatedHandler getMoveSummary :<|> 165 | validatedHandler getDataSummary :<|> 166 | validatedHandler getResultPercentages :<|> 167 | validatedHandler getGames :<|> 168 | validatedHandler gameEvaluations :<|> 169 | validatedHandler moveEvaluationHandler :<|> 170 | validatedHandler moveEvaluationFromIdHandler :<|> 171 | uploadDBHelper :<|> 172 | addEvaluations :<|> 173 | sendFeedback 174 | 175 | 176 | data FeedbackData = FeedbackData { fbText :: String, fbEmail :: String } deriving (Generic, FromJSON) 177 | 178 | trySendEmail :: String -> String -> String -> IO () 179 | trySendEmail subject to body = do 180 | let toAdd = Address Nothing (T.pack to) 181 | accessCode <- liftIO $ lookupEnv "AWS_ACCESS" 182 | secretCode <- liftIO $ lookupEnv "AWS_SECRET" 183 | let codes = liftM2 (,) accessCode secretCode 184 | liftIO $ maybe doNothing (uncurry (sendEmail subject toAdd body)) codes 185 | 186 | sendFeedback :: FeedbackData -> Handler b (Service b) () 187 | sendFeedback (FeedbackData feedbackText feedbackEmail) = 188 | liftIO $ 189 | trySendEmail "Feedback" "goldammer.christian@gmail.com" $ 190 | intercalate ": " [feedbackEmail, feedbackText] 191 | 192 | fromEmail :: String 193 | fromEmail = "cg@chrisgoldammer.com" 194 | 195 | fromAddress :: Address 196 | fromAddress = Address Nothing (T.pack fromEmail) 197 | 198 | type EmailBody = String 199 | type AwsAccess = String 200 | type AwsSecret = String 201 | 202 | sendEmail :: String -> Address -> EmailBody -> AwsAccess -> AwsSecret -> IO () 203 | sendEmail subject to body access secret = do 204 | let ses = SES (B.pack fromEmail) [] (B.pack access) (B.pack secret) Nothing usEast1 205 | let mail = simpleMail' to fromAddress (T.pack subject) (LT.pack body) 206 | manager :: Manager <- getGlobalManager 207 | renderSendMailSES manager ses mail 208 | return () 209 | 210 | 211 | -- We wrap the game list as a newtype so it can be passed nicely as JSON. 212 | -- The code would work without wrapping, but, due to HTML intriciacies, lists don't 213 | -- produce nice JSON, so the resulting URL would be extremely long. 214 | newtype WrappedGameList = WrappedGameList 215 | { gameList :: GameList 216 | } deriving (Generic, FromJSON, ToJSON) 217 | 218 | -- A newtype for JSON data sent as query parameter in get 219 | -- requests 220 | newtype JSONEncoded a = JSONEncoded 221 | { unJSONEncoded :: a 222 | } deriving (Eq, Show) 223 | 224 | -- A way to decode parameters that are sent through get requests 225 | instance (FromJSON a) => FromHttpApiData (JSONEncoded a) where 226 | parseQueryParam x = case eitherDecode $ LBS.fromStrict $ encodeUtf8 x of 227 | Left err -> Left (T.pack err) 228 | Right value -> Right (JSONEncoded value) 229 | 230 | instance (ToJSON a) => ToHttpApiData (JSONEncoded a) where 231 | toQueryParam (JSONEncoded x) = decodeUtf8 $ LBS.toStrict $ encode x 232 | 233 | validatedHandler :: 234 | (HasDefault d, QueryForDB q) 235 | => (q -> Handler b (Service b) d) 236 | -> Maybe (JSONEncoded q) 237 | -> Handler b (Service b) d 238 | validatedHandler = maybeHandlerJSON . validateRequestForDB 239 | 240 | -- Parsing the query parameters into JSON returns a `Maybe (JSONEncoded a)`. In practice, 241 | -- I'll usually have a function `h :: a -> Handler b Service d`, so this function 242 | -- creates the required handler from h and returning the monoid `mempty` if 243 | -- the query could not get parsed 244 | maybeHandlerJSON :: 245 | HasDefault d 246 | => (a -> Handler b (Service b) d) 247 | -> Maybe (JSONEncoded a) 248 | -> Handler b (Service b) d 249 | maybeHandlerJSON h = maybe (return defaultVal) (h . unJSONEncoded) 250 | 251 | maybeHandler :: 252 | HasDefault d 253 | => (a -> Handler b (Service b) d) 254 | -> Maybe a 255 | -> Handler b (Service b) d 256 | maybeHandler h = maybe (return defaultVal) h 257 | 258 | 259 | data TestData = TestData 260 | { testInt :: Int 261 | , testNames :: [String] 262 | } deriving (Show, Generic, FromJSON, ToJSON) 263 | 264 | testCall' :: TestData -> Handler b (Service b) [Int] 265 | testCall' td = return $ testInt td : fmap length (testNames td) 266 | 267 | serviceInit :: String -> SnapletLens b (AuthManager b) -> SnapletInit b (Service b) 268 | serviceInit dbName auth = makeSnaplet "chess" "Chess Service" Nothing $ do 269 | pg <- nestSnaplet "pg" servicePG pgsInit 270 | d <- nestSnaplet "db" serviceDB $ initPersistWithDB dbName (runMigrationUnsafe migrateAll) 271 | addRoutes chessRoutes 272 | 273 | -- Creating an MVar with a list of evaluation tasks 274 | -- and spinning of a thread to run those evaluations. 275 | tasks <- liftIO $ newMVar emptyTasks 276 | liftIO $ forkIO $ runEvalThread dbName tasks 277 | return $ Service pg d tasks auth 278 | 279 | chessRoutes :: [(B.ByteString, Handler b (Service b) ())] 280 | chessRoutes = [("", serveSnap chessApi apiServer)] 281 | 282 | type LoginUser = Maybe Int 283 | 284 | mkSnapletPgPoolWithDB :: (MonadIO (m b v), MonadSnaplet m) => String -> m b v ConnectionPool 285 | mkSnapletPgPoolWithDB dbName = do 286 | conf <- getSnapletUserConfig 287 | maybeSize <- liftIO $ DC.lookup conf "postgre-pool-size" 288 | let conStr = B.pack $ "host='localhost' dbname='chess_" ++ dbName ++ "' user='postgres'" 289 | let size = fromMaybe 1 maybeSize 290 | liftIO . runNoLoggingT $ PG.createPostgresqlPool conStr size 291 | 292 | initPersistWithDB :: String -> SqlPersistT (NoLoggingT IO) a -> SnapletInit b PersistState 293 | initPersistWithDB dbName = initPersistGeneric $ mkSnapletPgPoolWithDB dbName 294 | 295 | currentUserName :: Handler b (Service b) (Maybe String) 296 | currentUserName = do 297 | lens <- gets _serviceAuth 298 | user <- withTop lens currentUser 299 | let login = fmap (T.unpack . userLogin) user :: Maybe String 300 | return login 301 | 302 | type UserName = String 303 | newtype LoginException = LoginUserDoesNotExist UserName deriving Show 304 | instance Exception LoginException 305 | 306 | getAuthUserFromEmail :: String -> Handler b (Service b) (Maybe AuthUser) 307 | getAuthUserFromEmail userId = do 308 | auth <- gets _serviceAuth 309 | userIdInt <- getUserId userId 310 | 311 | let lookup i = withTop auth $ withBackend $ \r -> liftIO $ lookupByUserId r $ UserId (T.pack (show i)) 312 | maybeHandler lookup userIdInt 313 | 314 | forceLoginFromEmail :: String -> Handler b (Service b) (Maybe AppUser) 315 | forceLoginFromEmail userId = do 316 | auth <- gets _serviceAuth 317 | au <- getAuthUserFromEmail userId 318 | let forceLoginHandler a = withTop auth $ logout >> forceLogin a >> return Nothing 319 | maybeHandler forceLoginHandler au 320 | getMyUser 321 | 322 | selectUserId :: T.Text 323 | selectUserId = T.pack "SELECT id FROM snap_auth_user WHERE login = ?" 324 | 325 | type UserIdType = (Single Int) 326 | 327 | getUserId :: String -> Handler b (Service b) (Maybe Int) 328 | getUserId userId = do 329 | let arguments = [PersistText (T.pack userId)] 330 | userIds :: [UserIdType] <- runPersist $ rawSql selectUserId arguments 331 | return $ unSingle <$> listToMaybe userIds 332 | 333 | -- changeUser :: Maybe String -> Handler b (Service b) () 334 | -- changeUser _ = do 335 | -- return () 336 | 337 | instance HasPersistPool (Handler b (Service b)) where 338 | getPersistPool = with serviceDB getPersistPool 339 | 340 | instance HasPostgres (Handler b (Service b)) where 341 | getPostgresState = with servicePG get 342 | setLocalPostgresState = undefined 343 | 344 | data DataSummary = DataSummary { 345 | numberTournaments :: Int 346 | , numberGames :: Int 347 | , numberGameEvals :: Int 348 | , numberMoveEvals :: Int 349 | } deriving (Generic, Show, Eq, ToJSON, FromJSON) 350 | 351 | class HasDefault a where 352 | defaultVal :: a 353 | 354 | instance HasDefault (Maybe a) where 355 | defaultVal = Nothing 356 | 357 | instance HasDefault [a] where 358 | defaultVal = [] 359 | 360 | instance HasDefault DataSummary where 361 | defaultVal = DataSummary 0 0 0 0 362 | 363 | class QueryForDB a where 364 | getDB :: a -> Int 365 | 366 | instance QueryForDB DefaultSearchData where 367 | getDB = searchDB 368 | 369 | instance QueryForDB GameRequestData where 370 | getDB = gameRequestDB 371 | 372 | instance QueryForDB Ids where 373 | getDB = idDB 374 | 375 | type DBQueryType = (Single Int, Single Int, Single Int, Single Int) 376 | 377 | data DBResult = DBResult { 378 | dbResultId :: Int 379 | , dbResultGames :: Int 380 | , dbResultGamesEval :: Int 381 | , dbResultEvals :: Int 382 | } deriving (Generic) 383 | 384 | data DBResultFull = DBResultFull { 385 | dbResultNumbers :: DBResult 386 | , dbResultDB :: Database 387 | } deriving (Generic) 388 | 389 | instance ToJSON DBResult where 390 | toJSON = genericToJSON defaultOptions { fieldLabelModifier = renameField "dbResult"} 391 | 392 | instance ToJSON DBResultFull where 393 | toJSON = genericToJSON defaultOptions { fieldLabelModifier = renameField "dbResult"} 394 | 395 | toDBResults :: DBQueryType -> DBResult 396 | toDBResults (Single id, Single numGames, Single numGamesEval, Single numEvals) = 397 | DBResult id numGames numGamesEval numEvals 398 | 399 | combineMaybes :: Maybe a -> Maybe b -> (a -> b -> c) -> Maybe c 400 | combineMaybes (Just a) (Just b) f = Just (f a b) 401 | combineMaybes _ _ _ = Nothing 402 | 403 | getDatabaseStats :: Handler b (Service b) [DBResultFull] 404 | getDatabaseStats = do 405 | dbs <- getDatabases 406 | let dbKeys = fmap (dbKeyInt . entityKey) dbs 407 | let sub = substituteName "databases" 408 | let query = sub dbQuery dbKeys 409 | 410 | results :: [DBQueryType] <- runPersist $ rawSql query [] 411 | let groupedResults :: MP.Map Int DBResult = MP.fromList $ fmap (\r -> (dbResultId r, r)) $ fmap toDBResults results 412 | let groupedDBs :: MP.Map Int Database = MP.fromList $ fmap (\d -> ((dbKeyInt . entityKey ) d, entityVal d)) dbs 413 | 414 | -- Todo: Use a merge strategy that is likely much more efficient 415 | let combined = fmap (\i -> (MP.lookup i groupedResults, MP.lookup i groupedDBs)) dbKeys 416 | 417 | let dbResultsFull = catMaybes $ fmap (\(a, b) -> combineMaybes a b DBResultFull) combined 418 | return dbResultsFull 419 | 420 | 421 | newtype DefaultSearchData = DefaultSearchData { searchDB :: Int } deriving (Generic, FromJSON, ToJSON, Show) 422 | type QueryType = (Single Int, Single Int, Single Int, Single Int) 423 | 424 | getDataSummary :: DefaultSearchData -> Handler b (Service b) DataSummary 425 | getDataSummary searchData = do 426 | let db = searchDB searchData 427 | let arguments = replicate 4 $ PersistInt64 (fromIntegral db) 428 | results :: [QueryType] <- runPersist $ rawSql dataSummaryQuery arguments 429 | let (Single numTournaments, Single numGames, Single numGameEvals, Single numMoveEvals) = head results 430 | return $ DataSummary numTournaments numGames numGameEvals numMoveEvals 431 | 432 | data ResultPercentage = ResultPercentage { 433 | rpOwnElo :: Int 434 | , rpOpponentElo :: Int 435 | , rpEvaluation :: Int 436 | , rpWinPercentage :: Int 437 | , rpDrawPercentage :: Int 438 | , rpNumberEvals :: Int 439 | 440 | } deriving (Generic, FromJSON, ToJSON, Show) 441 | 442 | type ResultPercentageQueryResult = (Single Int, Single Int, Single Int, Single Int, Single Int, Single Int) 443 | 444 | toResultPercentage :: ResultPercentageQueryResult -> ResultPercentage 445 | toResultPercentage (Single ownRating, Single oppRating, Single evalGroup, Single winP, Single drawP, Single numberEvals) = 446 | ResultPercentage ownRating oppRating evalGroup winP drawP numberEvals 447 | 448 | getPlayers :: DefaultSearchData -> Handler b (Service b) [Entity Player] 449 | getPlayers searchData = 450 | runPersist $ do 451 | let db = val $ intToKeyDB $ searchDB searchData 452 | select $ 453 | distinct $ 454 | from $ \(p, g) -> do 455 | where_ $ 456 | ((g ^. GamePlayerWhiteId ==. p ^. PlayerId) ||. 457 | (g ^. GamePlayerBlackId ==. p ^. PlayerId)) &&. 458 | (g ^. GameDatabaseId ==. db) 459 | return p 460 | 461 | getDatabases :: Handler b (Service b) [Entity Database] 462 | getDatabases = do 463 | currentUserEvaluated :: Maybe String <- currentUserName 464 | liftIO $ print $ "Getting for " ++ show currentUserEvaluated 465 | runPersist $ do 466 | dbsPublic <- 467 | select $ 468 | from $ \db -> do 469 | where_ (db ^. DatabaseIsPublic) 470 | return db 471 | let searchUser = fromMaybe "" currentUserEvaluated 472 | let searchCondition dbp = 473 | (dbp ^. DatabasePermissionUserId ==. val searchUser) &&. 474 | (dbp ^. DatabasePermissionRead ==. val True) 475 | let mergeCondition db dbp = dbp ^. DatabasePermissionDatabaseId ==. db ^. DatabaseId 476 | dbsPersonal <- 477 | select $ 478 | distinct $ 479 | from $ \(db, dbp) -> do 480 | where_ $ mergeCondition db dbp &&. searchCondition dbp 481 | return db 482 | return $ dbsPublic ++ dbsPersonal 483 | 484 | getTournaments :: DefaultSearchData -> Handler b (Service b) [Entity Tournament] 485 | getTournaments searchData = runPersist $ do 486 | let db = val $ intToKeyDB $ searchDB searchData 487 | select $ distinct $ 488 | from $ \(t, g) -> do 489 | where_ $ (g^.GameDatabaseId ==. db) &&. (t^.TournamentId ==. g^.GameTournament) 490 | return t 491 | 492 | 493 | validateRequestForDB :: QueryForDB q => (q -> Handler b (Service b) c) -> q -> Handler b (Service b) c 494 | validateRequestForDB handler q = do 495 | let db = getDB q 496 | dbs <- getDatabases 497 | let keys = fmap (dbKeyInt . entityKey) dbs 498 | let found = db `elem` keys 499 | liftIO $ print $ "FOUND: " ++ show keys ++ show found ++ show db 500 | if found then handler q else fail "Wrong permission" 501 | 502 | evalData :: GameRequestData -> Handler b (Service b) ([Entity Player], [EvalResult]) 503 | evalData (GameRequestData db tournaments) = do 504 | let tournamentKeys = fmap intToKey tournaments 505 | players :: [Entity Player] <- getPlayers $ DefaultSearchData db 506 | evals <- getMoveEvals (intToKeyDB db) tournamentKeys 507 | return (players, evals) 508 | 509 | getEvalResults :: GameRequestData -> Handler b (Service b) [EvalResult] 510 | getEvalResults = fmap snd . evalData 511 | 512 | getMoveSummary :: GameRequestData -> Handler b (Service b) [MoveSummary] 513 | getMoveSummary grData = do 514 | (playerKeys, evals) <- evalData grData 515 | return $ summarizeEvals playerKeys evals 516 | 517 | selectEvalResults :: MonadIO m => Key Database -> [Key Tournament] -> SqlPersistT m [EvalResult] 518 | selectEvalResults db tournaments = do 519 | let tournamentMatch t = t ^. TournamentId `in_` valList tournaments 520 | let tournamentCondition t = if not (null tournaments) then tournamentMatch t else val True 521 | select $ 522 | from $ \(me, g, t) -> do 523 | where_ $ (me ^. MoveEvalGameId ==. g ^. GameId) &&. (g ^. GameTournament ==. t ^. TournamentId) &&. tournamentCondition t &&. (g^.GameDatabaseId ==. val db) 524 | return (me, g) 525 | 526 | getMoveEvals :: Key Database -> [Key Tournament] -> Handler b (Service b) [EvalResult] 527 | getMoveEvals db tournaments = runPersist $ selectEvalResults db tournaments 528 | 529 | printName :: GameAttributeId -> String 530 | printName = show 531 | 532 | gameRead :: Int -> String 533 | gameRead = show 534 | 535 | type GameEvaluation = Int 536 | type GameOutcome = Int 537 | type PlayerKey = Int 538 | type PlayerGameEvaluations = [(PlayerKey, [(GameEvaluation, GameOutcome)])] 539 | 540 | parseEvalResults :: 541 | (Single Int, Single Int, Single Int, Single Int) 542 | -> (PlayerKey, GameEvaluation, GameOutcome) 543 | parseEvalResults (_, Single playerId, Single evaluation, Single result) = 544 | (playerId, evaluation, result) 545 | 546 | gameEvaluations :: GameRequestData -> Handler b (Service b) PlayerGameEvaluations 547 | gameEvaluations grd = do 548 | games <- getJustGames grd 549 | let gl = fmap dbKey games 550 | runPersist $ rawExecute viewQuery [] 551 | results <- runPersist $ rawSql (substituteGameList evalQueryTemplate gl) [] 552 | let parsed = fmap parseEvalResults results 553 | let grouped = fmap (\(_, b, c) -> (b, c)) <$> groupWithVal (Lens.^._1) parsed 554 | return $ MP.toList grouped 555 | 556 | data UploadData = UploadData 557 | { uploadName :: String 558 | , uploadText :: T.Text 559 | } deriving (Generic, FromJSON) 560 | 561 | data UploadResult 562 | = UploadSuccess Int 563 | | UploadFailure RequestError 564 | deriving (Generic, ToJSON) 565 | 566 | data RequestError = UploadTooBig | NotLoggedIn deriving (Generic, ToJSON) 567 | 568 | data EvaluationRequest = EvaluationRequest 569 | { evaluationDB :: Int 570 | , evaluationOverwrite :: Bool 571 | } deriving (Generic, FromJSON) 572 | 573 | 574 | type EvaluationResult = Int 575 | 576 | -- A helper function so we can wait in tenth of seconds. 577 | waitTenths :: Int -> IO () 578 | waitTenths = threadDelay . (*100000) 579 | 580 | addEvaluations :: EvaluationRequest -> Handler b (Service b) () 581 | addEvaluations request = do 582 | let keyForDB = intToKeyDB $ evaluationDB request 583 | canWrite <- canWriteToDB keyForDB 584 | unless canWrite $ fail "wrong permission" 585 | 586 | let overwrite = evaluationOverwrite request 587 | dbName <- getDBName 588 | games :: [Entity Game] <- liftIO $ gamesInDB dbName keyForDB overwrite 589 | liftIO $ print $ "Games: " ++ show (length games) 590 | user <- currentUserName 591 | let newTask = Task "Evaluation" games dbName user 592 | m <- gets _serviceAllTasks 593 | tasks <- liftIO $ takeMVar m 594 | let afterTasks = addTask tasks newTask 595 | liftIO $ putMVar m afterTasks 596 | -- store the evaluations to file so I know what's currently running 597 | liftIO $ writeFile "/home/cg/chess-backend/log/tasks.log" $ show afterTasks 598 | return () 599 | 600 | 601 | doNothing :: IO () 602 | doNothing = return () 603 | 604 | runTask :: Task -> IO () 605 | runTask (Task _ games dbName _) = traverse (TF.storeEvaluationIO dbName) games >> doNothing 606 | 607 | -- The thread handler to run evaluations. The idea here is that 608 | -- we want to be able to asynchronously add evaluation tasks as they come 609 | -- in from user requests, but we only want to run at most one task 610 | -- at a time so we don't overload the CPU. In other words, this is a FIFO 611 | -- queue for tasks. 612 | -- This will likely be a bottleneck in the future, so expect this to change 613 | -- as more users upload databases. 614 | runEvalThread :: String -> MVar AllTasks -> IO () 615 | runEvalThread dbName m = do 616 | allTasks <- takeMVar m 617 | liftIO $ writeFile "/home/cg/chess-backend/log/tasks.log" $ show allTasks 618 | putMVar m allTasks 619 | let active = taskActive allTasks 620 | maybe doNothing (handleActiveTask m) active 621 | waitTenths 10 622 | runEvalThread dbName m 623 | 624 | handleActiveTask :: MVar AllTasks -> Task -> IO () 625 | handleActiveTask m task = do 626 | runTask task 627 | allTasksAfter <- takeMVar m 628 | putMVar m $ completeActiveTask allTasksAfter 629 | return () 630 | 631 | gamesInDB :: String -> Key Database -> Bool -> IO [Entity Game] 632 | gamesInDB dbName keyForDB overwrite = TH.inBackend (connString dbName) $ do 633 | let db = val keyForDB 634 | evaluatedGames :: [Entity Game] <- select $ distinct $ 635 | from $ \(g, me) -> do 636 | where_ $ (me ^. MoveEvalGameId ==. g^.GameId) &&. (g^.GameDatabaseId ==. db) 637 | return g 638 | allGames :: [Entity Game] <- select $ distinct $ 639 | from $ \g -> do 640 | where_ (g^.GameDatabaseId ==. db) 641 | return g 642 | let evaluatedIds = fmap entityKey evaluatedGames :: [Key Game] 643 | let difference = [g | g <- allGames, entityKey g `notElem` evaluatedIds] 644 | return $ if overwrite then allGames else difference 645 | 646 | 647 | getDBName :: Handler b (Service b) String 648 | getDBName = do 649 | _ <- getSnapletUserConfig 650 | dbNameMaybe :: Maybe String <- liftIO $ lookupEnv "type" 651 | liftIO $ print $ "Lookup: " ++ show dbNameMaybe 652 | return $ fromMaybe "dev" dbNameMaybe 653 | 654 | handleNoUser :: Handler b (Service b) UploadResult 655 | handleNoUser = do 656 | modifyResponse $ setResponseStatus 403 "Data too big" 657 | return $ UploadFailure NotLoggedIn 658 | 659 | uploadDBHelper :: UploadData -> Handler b (Service b) UploadResult 660 | uploadDBHelper upload = do 661 | currentUserEvaluated <- currentUserName 662 | maybe handleNoUser (\_ -> uploadDB upload) currentUserEvaluated 663 | 664 | -- Uploading a database from the db. The pgn is included 665 | -- in the `text` property of the JSON. 666 | -- We are rejecting all uploads that exceed a certain size. 667 | -- This is hacky, because optimally we'd want to server to not even respond 668 | -- to those requests, but I haven't figured out if this is possible 669 | -- to do in Nginx (I'd want a separate limit for this endpoint) 670 | uploadDB :: UploadData -> Handler b (Service b) UploadResult 671 | uploadDB upload = do 672 | let (name, text) = (uploadName upload, uploadText upload) 673 | let textLength = T.length text 674 | let maxTextLength = 1000 * 1024 675 | if textLength > maxTextLength 676 | then do 677 | modifyResponse $ setResponseStatus 403 "Data too big" 678 | return $ UploadFailure UploadTooBig 679 | else do 680 | dbName <- getDBName 681 | currentUserEvaluated :: Maybe String <- currentUserName 682 | (db, results) <- liftIO $ readTextIntoDB dbName name text False currentUserEvaluated 683 | runPersist transactionSave 684 | addDBPermission db currentUserEvaluated 685 | -- Storing evaluations for the database in an asynchronous thread. 686 | addEvaluations (EvaluationRequest (dbKeyInt db) False) 687 | return $ UploadSuccess $ length results 688 | 689 | canWriteToDB :: Key Database -> Handler b (Service b) Bool 690 | canWriteToDB keyForDB = do 691 | usr <- currentUserName 692 | dbp :: Maybe (Entity DatabasePermission) <- 693 | runPersist $ PsP.getBy $ UniqueDatabasePermission keyForDB (fromMaybe "" usr) 694 | let canWrite = maybe False (databasePermissionWrite . entityVal) dbp 695 | return canWrite 696 | 697 | 698 | addDBPermission :: Key Database -> Maybe String -> Handler b (Service b) (Key DatabasePermission) 699 | addDBPermission dbResult user = runPersist $ insert $ DatabasePermission dbResult (fromMaybe "" user) True True False 700 | 701 | data Ids = Ids { idDB :: Int, idValues :: [Int] } deriving (Generic, FromJSON) 702 | 703 | data GameRequestData = GameRequestData { 704 | gameRequestDB :: Int 705 | , gameRequestTournaments :: [Int] 706 | } deriving (Generic, FromJSON, ToJSON) 707 | 708 | newtype MoveEvaluationRequest = MoveEvaluationRequest { 709 | moveEvalGames :: GameList 710 | } deriving (Show, Generic, FromJSON) 711 | 712 | 713 | getMoveEvaluationData :: Bool -> Key Database -> [Key Game] -> TH.DataAction [MoveEvaluationData] 714 | getMoveEvaluationData doFilter db gameIds = do 715 | results :: [(Entity Game, Entity MoveEval)] <- select $ 716 | from $ \(g, me) -> do 717 | where_ $ (me ^. MoveEvalGameId ==. g ^. GameId) &&. ((g ^. GameId) `in_` valList gameIds) &&. 718 | (g ^. GameDatabaseId ==. val db) 719 | return (g, me) 720 | let filters = filter notAlreadyWinning . filter notAlreadyLosing . filter (highMoveLoss . moveEvalsMoveLoss) 721 | let activeFilter = if doFilter then filters else id 722 | let cleaned = activeFilter $ getEvalData results 723 | return cleaned 724 | 725 | moveLossCutoff :: Int 726 | moveLossCutoff = 200 727 | 728 | highMoveLoss :: MoveLoss -> Bool 729 | highMoveLoss (MoveLossMate _) = True 730 | highMoveLoss (MoveLossCP x) = x >= moveLossCutoff 731 | 732 | evalCutoff :: Int 733 | evalCutoff = 300 734 | 735 | notAlreadyWinning :: MoveEvaluationData -> Bool 736 | notAlreadyWinning dat = evalWithColor <= evalCutoff 737 | where eval = moveEvalsMoveEval dat 738 | wasWhite = moveEvalIsWhite eval 739 | evalNum = fromMaybe 0 $ moveEvalEval eval 740 | evalWithColor = if wasWhite then evalNum else (- evalNum) 741 | 742 | notAlreadyLosing :: MoveEvaluationData -> Bool 743 | notAlreadyLosing dat = evalWithColor >= (-evalCutoff) 744 | where eval = moveEvalsMoveEval dat 745 | wasWhite = moveEvalIsWhite eval 746 | evalNum = fromMaybe 0 $ moveEvalEvalBest eval 747 | evalWithColor = if wasWhite then evalNum else (- evalNum) 748 | 749 | moveEvaluationFromIdHandler :: Ids -> Handler b (Service b) [MoveEvaluationData] 750 | moveEvaluationFromIdHandler (Ids db values) = do 751 | let keyDB = intToKeyDB db 752 | runPersist $ getMoveEvaluationData False keyDB (fmap intToKeyGame values) 753 | 754 | moveEvaluationHandler :: GameRequestData -> Handler b (Service b) [MoveEvaluationData] 755 | moveEvaluationHandler grd = do 756 | games <- getJustGames grd 757 | let keyDB = intToKeyDB $ gameRequestDB grd 758 | runPersist $ getMoveEvaluationData True keyDB (fmap entityKey games) 759 | 760 | data MoveEvaluationData = MoveEvaluationData { 761 | moveEvalsGame :: Entity Game 762 | , moveEvalsMoveEval :: MoveEval 763 | , moveEvalsMoveLoss :: MoveLoss 764 | } deriving (Show, Generic) 765 | 766 | instance ToJSON MoveEvaluationData where 767 | toJSON = genericToJSON defaultOptions { fieldLabelModifier = renameField "moveEvals"} 768 | 769 | data MoveLoss = MoveLossCP Int | MoveLossMate Int deriving (Show, Generic, ToJSON) 770 | 771 | getEvalData :: [(Entity Game, Entity MoveEval)] -> [MoveEvaluationData] 772 | getEvalData dat = concat [evalGame game evals | (game, evals) <- grouped] 773 | where grouped = MP.toList $ fmap snd <$> groupWithVal fst dat :: [(Entity Game, [Entity MoveEval])] 774 | 775 | evalGame :: Entity Game -> [Entity MoveEval] -> [MoveEvaluationData] 776 | evalGame = fmap . evalHelper 777 | 778 | evalHelper :: Entity Game -> Entity MoveEval -> MoveEvaluationData 779 | evalHelper ga meEntity = MoveEvaluationData ga me $ getMoveLoss me 780 | where me = entityVal meEntity 781 | 782 | getMoveLoss :: MoveEval -> MoveLoss 783 | getMoveLoss (MoveEval _ _ isWhite movePlayed moveBest evalAfter evalBefore mateAfter mateBefore _ _ _ _) = 784 | if bestMovePlayed 785 | then MoveLossCP 0 786 | else moveLossBasic 787 | where 788 | moveLossBasic = getMoveLossHelper isWhite evalBefore evalAfter mateBefore mateAfter 789 | bestMovePlayed = movePlayed == Just moveBest 790 | 791 | getMoveLossHelper :: Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> MoveLoss 792 | getMoveLossHelper True (Just before) (Just after) _ _ = MoveLossCP $ before - after 793 | getMoveLossHelper False (Just before) (Just after) _ _ = MoveLossCP $ after - before 794 | getMoveLossHelper _ _ _ (Just _) (Just _) = MoveLossCP 0 795 | getMoveLossHelper _ _ (Just _) (Just before) _ = MoveLossMate (-before) 796 | getMoveLossHelper _ _ _ _ _= MoveLossCP 0 797 | 798 | getMyUser :: Handler b (Service b) (Maybe AppUser) 799 | getMyUser = currentUserName >>= runPersist . selectUser . fmap T.pack 800 | 801 | type GameData = (Entity Game, Entity Tournament, Maybe (Entity OpeningVariation), Maybe (Entity OpeningLine), Entity Player, Entity Player, Entity GameAttribute) 802 | 803 | data GameDataFormatted = GameDataFormatted { 804 | gameDataGame :: Entity Game 805 | , gameDataTournament :: Entity Tournament 806 | , gameDataOpening :: Maybe (Entity OpeningVariation) 807 | , gameDataOpeningLine :: Maybe (Entity OpeningLine) 808 | , gameDataPlayerWhite :: Entity Player 809 | , gameDataPlayerBlack :: Entity Player 810 | , gameDataAttributes :: [Entity GameAttribute]} deriving (Generic) 811 | 812 | instance Eq GameDataFormatted 813 | where g == g' = gameDataGame g == gameDataGame g' 814 | 815 | instance Show GameDataFormatted 816 | where show = fmap show gameDataGame 817 | 818 | renameField :: String -> String -> String 819 | renameField toDrop s = lowerFirst $ drop (length toDrop) s 820 | 821 | lowerFirst :: String -> String 822 | lowerFirst = over _head toLower . over (_tail.each) id 823 | 824 | instance ToJSON GameDataFormatted where 825 | toJSON = genericToJSON defaultOptions { fieldLabelModifier = renameField "gameData"} 826 | 827 | getGamesHandler :: 828 | GameRequestData -> (GameRequestData -> SqlPersistM [a]) -> Handler b (Service b) [a] 829 | getGamesHandler requestData getter = do 830 | usr <- currentUserName 831 | let keyForDB = intToKeyDB $ gameRequestDB requestData 832 | db :: Maybe Database <- runPersist $ PsP.get keyForDB 833 | dbp :: Maybe (Entity DatabasePermission) <- 834 | runPersist $ PsP.getBy $ UniqueDatabasePermission keyForDB (fromMaybe "" usr) 835 | let dbPublic = fmap databaseIsPublic db == Just True 836 | let userLoggedIn = isJust usr 837 | let userCanRead = 838 | isJust dbp && (fmap (databasePermissionRead . PsP.entityVal) dbp == Just True) 839 | if dbPublic || (userLoggedIn && userCanRead) 840 | then runPersist $ getter requestData 841 | else return [] 842 | 843 | getGames :: GameRequestData -> Handler b (Service b) [GameDataFormatted] 844 | getGames requestData = gameGrouper <$> getGamesHandler requestData getGames' 845 | 846 | getJustGames :: GameRequestData -> Handler b (Service b) [Entity Game] 847 | getJustGames requestData = getGamesHandler requestData getJustGames' 848 | 849 | groupSplitter :: [GameData] -> GameDataFormatted 850 | groupSplitter ((g, t, ov, ol, pWhite, pBlack, ga):rest) = 851 | GameDataFormatted g t ov ol pWhite pBlack allAttributes 852 | where 853 | allAttributes = ga : restAttributes 854 | restAttributes = fmap (\(_, _, _, _, _, _, r) -> r) rest :: [Entity GameAttribute] 855 | 856 | gameDataEqual :: GameData -> GameData -> Bool 857 | gameDataEqual gd gd' = gameKey gd == gameKey gd' 858 | where gameKey dat = entityKey (dat Lens.^._1) 859 | 860 | gameGrouper :: [GameData] -> [GameDataFormatted] 861 | gameGrouper allGames = groupSplitter <$> Data.List.groupBy gameDataEqual allGames 862 | 863 | getJustGames' :: MonadIO m => GameRequestData -> SqlPersistT m [Entity Game] 864 | getJustGames' gr = fmap (Lens.^. _1) <$> getGames' gr 865 | 866 | getGames' :: MonadIO m => GameRequestData -> SqlPersistT m [GameData] 867 | getGames' (GameRequestData dbInt tournaments) = do 868 | let db = intToKeyDB dbInt 869 | let tournamentKeys = fmap intToKey tournaments 870 | let tournamentMatch t = t ^. TournamentId `in_` valList tournamentKeys 871 | select $ 872 | from $ \(g `InnerJoin` t `InnerJoin` pWhite `InnerJoin` pBlack `InnerJoin` ga `LeftOuterJoin` ov `LeftOuterJoin` ol) -> do 873 | on (ov ?. OpeningVariationLine ==. ol ?. OpeningLineId) 874 | on (g ^. GameOpeningVariation ==. ov ?. OpeningVariationId) 875 | on (ga ^. GameAttributeGameId ==. g ^. GameId) 876 | on (pBlack ^. PlayerId ==. g ^. GamePlayerBlackId) 877 | on (pWhite ^. PlayerId ==. g ^. GamePlayerWhiteId) 878 | on (g ^. GameTournament ==. t ^. TournamentId) 879 | where_ $ 880 | (g ^. GameDatabaseId ==. val db) 881 | &&. (if not (null tournaments) then tournamentMatch t else not_ (tournamentMatch t)) 882 | return (g, t, ov, ol, pWhite, pBlack, ga) 883 | 884 | 885 | getResultPercentages :: DefaultSearchData -> Handler b (Service b) [ResultPercentage] 886 | getResultPercentages searchData = do 887 | let db = searchDB searchData 888 | results <- runPersist $ rawSql resultPercentageQuery [PersistInt64 (fromIntegral db)] 889 | return $ fmap toResultPercentage results 890 | 891 | -- |A useful handler for testing 892 | nothingHandler :: Handler b (Service b) () 893 | nothingHandler = return () 894 | 895 | createFullUser :: String -> String -> Handler b (Service b) () 896 | createFullUser userEmail password = do 897 | lens <- gets _serviceAuth 898 | res <- withTop lens $ createUser (T.pack userEmail) (B.pack password) 899 | case res of 900 | Right authUser -> do 901 | let usId = userLogin authUser 902 | createAppUser usId 903 | withTop lens (forceLogin authUser) 904 | -- Left af -> return () 905 | return () 906 | 907 | 908 | -- |Create a default app user. The id for the app user is the user name. 909 | createAppUser :: T.Text -> Handler b (Service b) () 910 | createAppUser userLoginCreate = do 911 | time <- liftIO getCurrentTime 912 | runPersist $ insert_ $ AppUser (T.unpack userLoginCreate) Nothing time 913 | return () 914 | 915 | -- |Obtain the app user by user name. 916 | selectUser :: MonadIO m => Maybe T.Text -> SqlPersistT m (Maybe AppUser) 917 | selectUser (Just userId) = do 918 | users <- select $ from $ \usr -> do 919 | where_ $ usr ^. AppUserUserId ==. val (T.unpack userId) 920 | return usr 921 | return $ entityVal <$> listToMaybe users 922 | selectUser Nothing = return Nothing 923 | -------------------------------------------------------------------------------- /src/Services/Sql.hs: -------------------------------------------------------------------------------- 1 | -- |This contains all raw SQL pulls and related functions. I pull these out 2 | -- into their own module. The next step is to cleanly encapsulate them and only 3 | -- expose safe functions that cannot cause runtime errors. 4 | 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE DeriveAnyClass #-} 9 | 10 | 11 | module Services.Sql where 12 | 13 | import Data.Maybe (fromMaybe) 14 | import qualified Data.Text as T (Text, pack, unpack) 15 | import qualified Data.Text.Lazy as TL (toStrict) 16 | import Data.Text.Template (Context, substitute) 17 | import Services.DatabaseHelpers (listToInClause) 18 | import Text.RawString.QQ (r) 19 | 20 | 21 | type GameList = [Int] 22 | 23 | substituteName :: String -> T.Text -> GameList -> T.Text 24 | substituteName name template ints = TL.toStrict $ substitute template cont 25 | where cont = context [(name, listToInClause ints)] 26 | 27 | substituteGameList :: T.Text -> GameList -> T.Text 28 | substituteGameList = substituteName "gameList" 29 | 30 | 31 | -- | Create 'Context' from association list. 32 | context :: [(String, String)] -> Context 33 | context assocs x = T.pack $ fromMaybe err . lookup (T.unpack x) $ assocs 34 | where err = error $ "Could not find key: " ++ T.unpack x 35 | 36 | -- |Summarizes a `Database` through the following metrics: 37 | -- number of tournaments 38 | -- number of games 39 | -- number of games with evaluations 40 | -- number of evaluated moves 41 | dataSummaryQuery :: T.Text 42 | dataSummaryQuery = [r| 43 | WITH 44 | numberTournaments as (SELECT count(distinct id) as "numberTournaments" FROM tournament where database_id=?) 45 | , numberGames as (SELECT count(distinct id) as "numberGames" FROM game where database_id=?) 46 | , numberGameEvals as ( 47 | SELECT count(distinct id) as "numberGameEvals" FROM ( 48 | SELECT id FROM game WHERE id in ( 49 | SELECT DISTINCT game_id FROM move_eval 50 | ) and game.database_id=? 51 | ) as numberGameEvals 52 | ) 53 | , numberMoveEvals as ( 54 | SELECT count(*) as "numberMoveEvals" 55 | FROM move_eval 56 | JOIN game on move_eval.game_id = game.id 57 | WHERE game.database_id=? 58 | ) 59 | SELECT * 60 | FROM numberTournaments 61 | CROSS JOIN numberGames 62 | CROSS JOIN numberGameEvals 63 | CROSS JOIN numberMoveEvals 64 | |] 65 | 66 | -- Database overview 67 | dbQuery :: T.Text 68 | dbQuery = [r| 69 | SELECT 70 | db.id AS id 71 | , count(distinct g.id) as games 72 | , count(distinct me.game_id) as games_evaluated 73 | , sum((me.id is not null)::Int) as number_evals 74 | FROM game g 75 | JOIN database db ON db.id=g.database_id 76 | LEFT JOIN move_eval me ON g.id=me.game_id 77 | WHERE db.id in $databases 78 | GROUP BY db.id; 79 | |] 80 | 81 | 82 | -- |Creates a view that calculates the centipawn loss of a move. This is done 83 | -- taking the difference between the evaluation after the move that was best and 84 | -- the move that was made. Doing this quickly requires using a lag function in postgres 85 | -- thus, this is done in SQL, not through Esqueleto. 86 | -- In pseudo-code, the evaluation of a move is max(eval - lag(eval, 1), 0) if the player that moves 87 | -- had the white pieces and the inverse of that if the player was playing with the black pieces. 88 | viewQuery :: T.Text 89 | viewQuery = 90 | [r| 91 | CREATE OR REPLACE VIEW moveevals as ( 92 | SELECT 93 | game_id 94 | , is_white 95 | , move_number 96 | , greatest(((is_white :: Int)*2-1)*(eval_best - eval), 0) as cploss 97 | FROM move_eval 98 | ); 99 | |] 100 | 101 | evalQueryTemplate :: T.Text 102 | evalQueryTemplate = [r| 103 | WITH me_player as ( 104 | SELECT g.id as game_id, player_white_id, player_black_id, is_white, cploss, game_result 105 | FROM moveevals me 106 | JOIN game g 107 | ON me.game_id = g.id 108 | WHERE g.id in $gameList 109 | ) 110 | SELECT game_id, player_white_id as player_id, avg(cploss)::Int as cploss, avg((game_result+1)*100/2)::Int as result from me_player WHERE is_white group by game_id, player_white_id 111 | UNION ALL 112 | SELECT game_id, player_black_id as player_id, avg(cploss)::Int as cploss, avg((-game_result+1)*100/2)::Int as result from me_player WHERE not is_white group by game_id, player_black_id; 113 | |] 114 | 115 | resultPercentageQuery :: T.Text 116 | resultPercentageQuery = [r| 117 | SELECT 118 | rating_own 119 | , rating_opponent 120 | , eval 121 | , round(100 * avg((result=1)::Int)) :: Int as share_win 122 | , round(100 * avg((result=0)::Int)) :: Int as share_draw 123 | , count(*) as number_evals 124 | FROM ( 125 | SELECT 126 | game_result * ((is_white :: Int) * 2 - 1) as result 127 | , 100 * floor(rating1.rating/100) as rating_own 128 | , 100 * floor(rating2.rating/100) as rating_opponent 129 | , round((eval * ((is_white :: Int) * 2 - 1)/100)) as eval 130 | , move_number 131 | , (is_white :: Int) * 2 - 1 as color_int 132 | FROM game 133 | JOIN player_rating as rating1 ON 134 | game.player_white_id=rating1.player_id 135 | AND extract(year from game.date)=rating1.year 136 | AND extract(month from game.date)=rating1.month 137 | JOIN player_rating as rating2 ON 138 | game.player_black_id=rating2.player_id 139 | AND extract(year from game.date)=rating2.year 140 | AND extract(month from game.date)=rating2.month 141 | JOIN move_eval on game.id=move_eval.game_id 142 | WHERE 143 | move_number>0 144 | AND game.database_id=? 145 | AND eval is not null 146 | ) values 147 | GROUP BY rating_own, rating_opponent, eval 148 | |] 149 | -------------------------------------------------------------------------------- /src/Services/StatsHelpers.hs: -------------------------------------------------------------------------------- 1 | -- |Assorted statistical functions needed as part of the app. 2 | module Services.StatsHelpers where 3 | 4 | -- Arithmetic mean 5 | mean :: (Floating a) => [a] -> a 6 | mean xs = sum xs / (fromIntegral . length) xs 7 | 8 | var :: (Floating a) => [a] -> a 9 | var xs = sum (map (\x -> (x - m)^(2::Integer)) xs) / (fromIntegral (length xs)-1) 10 | where m = mean xs 11 | 12 | stdDev :: (Floating a) => [a] -> a 13 | stdDev x = sqrt $ var x 14 | 15 | stdError :: (Floating a) => [a] -> a 16 | stdError x = stdDev x / sqrt num 17 | where num = fromIntegral $ length x 18 | 19 | intAverage :: [Int] -> Int 20 | intAverage x = div (sum x) (length x) 21 | 22 | -------------------------------------------------------------------------------- /src/Services/Tasks.hs: -------------------------------------------------------------------------------- 1 | -- This provides the data types to handle asynchronous tasks. 2 | -- Right now, we only have one type of task, to add evaluations, 3 | -- but in the future, this task will likely cover more use cases. 4 | 5 | module Services.Tasks 6 | ( AllTasks(..) 7 | , Task(..) 8 | , Tasks 9 | , addTask 10 | , completeActiveTask 11 | , emptyTasks 12 | ) where 13 | 14 | import Services.Types 15 | import Database.Persist (Entity) 16 | 17 | data Task = Task 18 | { taskName :: String 19 | , taskGames :: [Entity Game] 20 | , taskDB :: String 21 | , userName :: Maybe String 22 | } 23 | 24 | type Tasks = [Task] 25 | 26 | data AllTasks = AllTasks 27 | { tasksScheduled :: Tasks 28 | , taskActive :: Maybe Task 29 | , tasksDone :: Tasks 30 | } deriving (Show) 31 | 32 | showTask :: Task -> String 33 | showTask (Task name games db taskUser) = 34 | "User: " ++ 35 | show taskUser ++ " db: " ++ db ++ " games: " ++ show (length games) ++ " name: " ++ name 36 | 37 | instance Show Task where 38 | show = showTask 39 | 40 | 41 | moveScheduledToActive :: AllTasks -> AllTasks 42 | moveScheduledToActive tasks@(AllTasks _ (Just _) _) = tasks 43 | moveScheduledToActive tasks@(AllTasks [] _ _) = tasks 44 | moveScheduledToActive (AllTasks (first:rest) Nothing done) = 45 | AllTasks rest (Just first) done 46 | 47 | addTask :: AllTasks -> Task -> AllTasks 48 | addTask (AllTasks sched act done) task = 49 | moveScheduledToActive $ AllTasks (task : sched) act done 50 | 51 | completeActiveTask :: AllTasks -> AllTasks 52 | completeActiveTask tasks@(AllTasks _ Nothing _) = tasks 53 | completeActiveTask (AllTasks sched (Just t) done) = 54 | moveScheduledToActive $ AllTasks sched Nothing (t : done) 55 | 56 | emptyTasks :: AllTasks 57 | emptyTasks = AllTasks [] Nothing [] 58 | 59 | -------------------------------------------------------------------------------- /src/Services/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE EmptyDataDecls #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE DerivingStrategies #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module Services.Types where 16 | 17 | import Data.Aeson (toJSON) 18 | import Data.Time (Day, UTCTime) 19 | import Database.Persist (Entity, entityKey) 20 | import Database.Persist.TH (mkMigrate, mkPersist, persistLowerCase, share, sqlSettings) 21 | 22 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 23 | 24 | Database json 25 | name String 26 | isPublic Bool 27 | userId String Maybe 28 | UniqueDatabaseName name 29 | 30 | DatabasePermission json 31 | databaseId DatabaseId 32 | userId String 33 | write Bool 34 | read Bool 35 | admin Bool 36 | UniqueDatabasePermission databaseId userId 37 | 38 | Tournament json 39 | databaseId DatabaseId 40 | name String 41 | UniqueTournamentName databaseId name 42 | 43 | Game json 44 | databaseId DatabaseId 45 | playerWhiteId PlayerId 46 | playerBlackId PlayerId 47 | gameResult Int 48 | tournament TournamentId 49 | pgn String 50 | date Day Maybe 51 | openingVariation OpeningVariationId Maybe 52 | UniqueGame databaseId playerWhiteId playerBlackId tournament pgn 53 | 54 | GameAttribute json 55 | gameId GameId 56 | attribute String 57 | value String 58 | 59 | Position json 60 | fen String 61 | UniquePosition fen 62 | 63 | PositionAttribute json 64 | positionId PositionId 65 | typ Int 66 | value Int 67 | UniquePositionAttribute positionId typ 68 | 69 | MoveEval json 70 | gameId GameId 71 | moveNumber Int 72 | isWhite Bool 73 | movePlayed String Maybe 74 | moveBest String 75 | eval Int Maybe 76 | evalBest Int Maybe 77 | mate Int Maybe 78 | mateBest Int Maybe 79 | complexityGB Int Maybe 80 | fen String 81 | engineVersion String "default='SF 10'" 82 | created UTCTime 83 | UniqueMoveEval gameId moveNumber isWhite 84 | 85 | Player json 86 | databaseId DatabaseId 87 | firstName String 88 | lastName String 89 | FullName databaseId firstName lastName 90 | 91 | PlayerRating json 92 | playerId PlayerId 93 | year Int 94 | month Int 95 | rating Int 96 | UniqueRating playerId year month 97 | 98 | AppUser json 99 | userId String 100 | name String Maybe 101 | subscriptionTime UTCTime 102 | deriving Show 103 | 104 | OpeningCode json 105 | code String 106 | UniqueOpeningCode code 107 | 108 | OpeningLine json 109 | name String 110 | UniqueOpeningLine name 111 | 112 | OpeningVariation json 113 | variationName String 114 | fen String 115 | standardMoves String 116 | code OpeningCodeId 117 | line OpeningLineId 118 | UniqueOpeningName fen 119 | 120 | TestThing json 121 | name String 122 | |] 123 | 124 | instance Eq AppUser 125 | where g == g' = appUserUserId g == appUserUserId g' 126 | 127 | instance Show Database 128 | where show = show . toJSON 129 | 130 | instance Show MoveEval 131 | where show = show . toJSON 132 | 133 | instance Show Game 134 | where show = show . toJSON 135 | 136 | instance Show Player where 137 | show p = playerFirstName p ++ " " ++ playerLastName p 138 | 139 | instance {-# Overlaps #-} Eq (Entity Game) 140 | where g == g' = entityKey g == entityKey g' 141 | 142 | instance {-# Overlaps #-} Ord (Entity Game) where 143 | g >= g' = entityKey g >= entityKey g' 144 | g <= g' = entityKey g <= entityKey g' 145 | -------------------------------------------------------------------------------- /src/Test/Fixtures.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | 10 | module Test.Fixtures where 11 | 12 | import Control.Monad (void) 13 | import Control.Monad.Reader (MonadIO, MonadReader, liftIO, reader, runReaderT) 14 | import Control.Monad.Trans.Reader (ReaderT) 15 | import Data.Either (rights) 16 | import Data.Either.Combinators (rightToMaybe) 17 | import Data.Text as Te (Text, pack) 18 | import Data.Time.Clock (getCurrentTime, UTCTime) 19 | import Database.Persist (Key, insertBy) 20 | import qualified Database.Persist.Postgresql as PsP (getBy) 21 | import Database.Persist.Sql 22 | import Debug.Trace (traceShow) 23 | import qualified Filesystem.Path.CurrentOS as FS (fromText) 24 | import System.Directory (listDirectory) 25 | import Text.RawString.QQ (r) 26 | import qualified Turtle as Tu (input, strict) 27 | import AppTypes 28 | import Services.DatabaseHelpers as DatabaseHelpers 29 | import Services.Types 30 | import Services.Helpers 31 | ( dbKeyInt ) 32 | 33 | import Test.Helpers as Helpers 34 | 35 | import qualified Chess.Pgn.Logic as Pgn 36 | import qualified Chess.Logic as Logic 37 | import qualified Chess.Metrics as Metrics 38 | 39 | import qualified Chess.Board as Board 40 | import qualified Chess.Stockfish as Stockfish 41 | 42 | -- The connection string is obtained from the command line 43 | -- Also, get settings for whether to create fake data. 44 | 45 | -- | The settings are obtained from the command line and determine 46 | -- how the data is stored. 47 | -- If the `settingsDelete` flag is set, all data is deleted from the database 48 | -- before data is read in. 49 | -- By default, data is not overwritten. If the program is stopped in the middle of inserting data 50 | -- then running it again should simply continue the data insertion. 51 | data FixtureSettings = FixtureSettings 52 | { settingsDBName :: String 53 | , settingsRunEval :: Bool 54 | , settingsOnlyContinueEval :: Bool 55 | } deriving (Show) 56 | 57 | type OnlyContinue = Bool 58 | 59 | data SettingsInput = SettingsInput AppType OnlyContinue 60 | 61 | doNothing :: IO () 62 | doNothing = return () 63 | 64 | runJob :: FixtureSettings -> IO () 65 | runJob settings = do 66 | let conn = connString $ settingsDBName settings 67 | let onlyContinueEval = settingsOnlyContinueEval settings 68 | if not onlyContinueEval then deleteDBContents conn else doNothing 69 | runReaderT readerActions settings 70 | return () 71 | 72 | doNothing' :: ReaderT FixtureSettings IO () 73 | doNothing' = return () 74 | 75 | readerActions :: ReaderT FixtureSettings IO () 76 | readerActions = do 77 | continue <- reader settingsOnlyContinueEval 78 | evaluate <- reader settingsRunEval 79 | if continue 80 | then if evaluate then evaluateGames else doNothing' 81 | else do 82 | storeGamesIntoDB 83 | if evaluate then evaluateGames else doNothing' 84 | return () 85 | 86 | getFolderPgns :: String -> IO [String] 87 | getFolderPgns folder = do 88 | allFiles :: [String] <- listDirectory $ "data/games/" ++ folder 89 | let extension = reverse . take 4 . reverse 90 | let files = filter ((==".pgn") . extension) allFiles 91 | return [folder ++ "/" ++ name | name <- files] 92 | 93 | fileSetsProd :: [(String, String)] 94 | fileSetsProd = 95 | [ ("World Championships 1886-2014", "prod/world_champion") 96 | , ("Candidates 2011-2018", "prod/candidates") 97 | , ("Wijk An Zee (Tata Steel) 2012-2018", "prod/wijk") 98 | , ("Rejkjavik Open 2018", "prod/rejkjavik") 99 | , ("Supertournaments 2017", "prod/super2017") 100 | ] 101 | 102 | parseSet :: String -> String -> IO (String, [String]) 103 | parseSet name folder = do 104 | files :: [String] <- getFolderPgns folder 105 | return (name, files) 106 | 107 | filesDev :: [(String, [String])] 108 | filesDev = 109 | [ ("Rejkjavik small", ["dev/rejkjavik2018.pgn"]) 110 | ] 111 | 112 | getFiles :: AppType -> IO [(String, [String])] 113 | getFiles Dev = return filesDev 114 | getFiles Test = return [("dummy games", ["dev/dummy_games.pgn"])] 115 | getFiles Prod = mapM (uncurry parseSet) fileSetsProd 116 | 117 | 118 | storeGamesIntoDB :: (MonadReader FixtureSettings m, MonadIO m) => m () 119 | storeGamesIntoDB = do 120 | dbName <- reader settingsDBName 121 | files <- liftIO (getFiles (getAppType dbName)) 122 | mapM_ storeFilesIntoDB files 123 | 124 | -- Example usage: 125 | -- storeFile "dummy" "dev/dummy_games.pgn" "dev" 126 | storeFile :: MonadIO m => String -> String -> String -> m () 127 | storeFile dbName chessDBName fileName = do 128 | let fullName = "/home/cg/data/chess-database-backend/games/" ++ fileName 129 | fileText <- Tu.strict $ Tu.input $ FS.fromText $ Te.pack fullName 130 | DatabaseHelpers.readTextIntoDB dbName chessDBName fileText True Nothing 131 | return () 132 | 133 | storeFilesIntoDB :: 134 | (MonadReader FixtureSettings m, MonadIO m) => (String, [String]) -> m () 135 | storeFilesIntoDB (chessDBName, fileNames) = do 136 | dbName <- reader settingsDBName 137 | liftIO $ inBackend (connString dbName) $ mapM_ (storeFile dbName chessDBName) fileNames 138 | return () 139 | 140 | evaluateGames :: (MonadReader FixtureSettings m, MonadIO m) => m () 141 | evaluateGames = do 142 | dbName <- reader settingsDBName 143 | continueEval <- reader settingsOnlyContinueEval 144 | games <- liftIO $ inBackend (connString dbName) $ do 145 | dbGames :: [Entity Game] <- getGamesFromDB continueEval 146 | return dbGames 147 | let gamesReversed = reverse games 148 | concat <$> mapM doEvaluation gamesReversed 149 | return () 150 | 151 | doEvaluation :: 152 | (MonadReader FixtureSettings m, MonadIO m) => Entity Game -> m [Key MoveEval] 153 | doEvaluation dbGame = do 154 | dbName <- reader settingsDBName 155 | storeEvaluationIO dbName dbGame 156 | 157 | type SummaryFunction = Int -> Logic.Game -> IO [Pgn.MoveSummary] 158 | 159 | getEvalKeys :: MoveEval -> Unique MoveEval 160 | getEvalKeys m = UniqueMoveEval (moveEvalGameId m) (moveEvalMoveNumber m) (moveEvalIsWhite m) 161 | 162 | storeEvaluationIOHelper :: 163 | MonadIO m => SummaryFunction -> String -> Entity Game -> m [Key MoveEval] 164 | storeEvaluationIOHelper summaryFunction dbName dbGame = do 165 | let maybeGame = dbGameToPGN $ entityVal dbGame 166 | let evalTime = 100 167 | time <- liftIO getCurrentTime 168 | case maybeGame of 169 | (Just game) -> do 170 | summaries <- liftIO $ summaryFunction evalTime game 171 | liftIO $ 172 | inBackend (connString dbName) $ do 173 | let rows = evalToRow (entityKey dbGame) summaries time 174 | mapM_ deleteBy $ fmap getEvalKeys rows 175 | k <- mapM insertBy rows 176 | return $ rights k 177 | Nothing -> return [] 178 | 179 | storeEvaluationIO :: MonadIO m => String -> Entity Game -> m [Key MoveEval] 180 | storeEvaluationIO = storeEvaluationIOHelper Pgn.gameSummaries 181 | 182 | storeEvaluationIOFake :: MonadIO m => String -> Entity Game -> m [Key MoveEval] 183 | storeEvaluationIOFake = storeEvaluationIOHelper Pgn.gameSummariesFake 184 | 185 | 186 | -- | Adds structured player ratings to the database. 187 | -- These ratings are already stored in raw format as part of the 188 | -- `game_tag` table. Here, we turn this raw data into monthly player 189 | -- evaluations. 190 | -- The monthly evaluation is simply the average of the player's raw rating 191 | -- over all games in a certain month. If a player has not played any games in 192 | -- a certain month, the `player_rating` table will not contain any data for this month. 193 | -- If you are using this data to report player ratings graphs, you might 194 | -- want to fill in this missing time period with the latest preceding rating. 195 | ratingQuery :: Text 196 | ratingQuery = [r| 197 | SELECT player_id, extract(year from date) as year, extract(month from date) as month, avg(rating)::Int 198 | FROM ( 199 | SELECT player_black_id as player_id, date, COALESCE(CONVERT_TO_INTEGER(VALUE), 0) as rating 200 | FROM game 201 | JOIN game_attribute ON game.id=game_attribute.game_id AND attribute='BlackElo' and value != '' 202 | UNION ALL 203 | SELECT player_white_id as player_id, date, COALESCE(CONVERT_TO_INTEGER(VALUE), 0) as rating 204 | FROM game 205 | JOIN game_attribute ON game.id=game_attribute.game_id AND attribute='WhiteElo' and value != '' 206 | WHERE value ~ E'^\\d+$' 207 | ) values 208 | WHERE rating > 0 and date is not null 209 | GROUP BY player_id, year, month 210 | |] 211 | 212 | type RatingQueryType = (Single Int, Single Int, Single Int, Single Int) 213 | 214 | intToKey :: Int -> Key Player 215 | intToKey = toSqlKey . fromIntegral 216 | 217 | readRatingQuery :: RatingQueryType -> PlayerRating 218 | readRatingQuery (Single player_id, Single year, Single month, Single rating) = PlayerRating (intToKey player_id) year month rating 219 | 220 | addRatings :: DataAction () 221 | addRatings = do 222 | results :: [RatingQueryType] <- rawSql ratingQuery [] 223 | mapM_ (insertBy . readRatingQuery) results 224 | 225 | sqlGamesAll :: Text 226 | sqlGamesAll = [r| 227 | SELECT ?? 228 | FROM game 229 | |] 230 | 231 | sqlGamesUnevaluated :: Text 232 | sqlGamesUnevaluated = [r| 233 | SELECT ?? 234 | FROM game 235 | WHERE game.id not in (SELECT DISTINCT game_id from move_eval) 236 | |] 237 | 238 | sqlGamesOutdated :: Text 239 | sqlGamesOutdated = [r| 240 | SELECT ?? 241 | FROM game 242 | WHERE 243 | game.id IN ( 244 | SELECT DISTINCT game_id FROM move_eval 245 | WHERE engine_version !=? 246 | ) 247 | AND 248 | database_id = ? 249 | |] 250 | 251 | getGamesFromDB :: Bool -> DataAction [Entity Game] 252 | getGamesFromDB continueEval = do 253 | let query = if continueEval then sqlGamesUnevaluated else sqlGamesAll 254 | games :: [Entity Game] <- rawSql query [] 255 | return games 256 | 257 | latestEngine :: String 258 | latestEngine = "SF 14.1" 259 | 260 | getGamesOutdated :: String -> String -> DataAction [Entity Game] 261 | getGamesOutdated latestEngineName dbName = do 262 | db <- PsP.getBy $ UniqueDatabaseName dbName 263 | case db of 264 | Just dbResult -> do 265 | let dbInt = PersistInt64 $ fromIntegral $ dbKeyInt $ entityKey dbResult 266 | let params = [PersistText (Te.pack latestEngineName), dbInt] 267 | rawSql sqlGamesOutdated params 268 | Nothing -> return [] 269 | 270 | evalToRow :: Key Game -> [Pgn.MoveSummary] -> UTCTime -> [MoveEval] 271 | evalToRow g ms time = traceShow ("Move summary" ++ show ms) $ evalToRowColor g 1 Board.White ms time 272 | 273 | evalToRowColor :: Key Game -> Int -> Board.Color -> [Pgn.MoveSummary] -> UTCTime -> [MoveEval] 274 | evalToRowColor _ _ _ [] _ = [] 275 | evalToRowColor g n Board.White (ms:rest) time = 276 | constructEvalMove g n True ms time : evalToRowColor g n Board.Black rest time 277 | evalToRowColor g n Board.Black (ms:rest) time = 278 | constructEvalMove g n False ms time : evalToRowColor g (n + 1) Board.White rest time 279 | 280 | constructEvalMove :: Key Game -> Int -> Bool -> Pgn.MoveSummary -> UTCTime -> MoveEval 281 | constructEvalMove gm n isWhite (Pgn.MoveSummary mv mvBest evalMove evalBest fen comp) = 282 | MoveEval gm n isWhite (Just mv) mvBest eval evalB mate mateB (Just comp) fen latestEngine 283 | where 284 | (eval, mate) = (evalInt evalMove, evalMate evalMove) 285 | (evalB, mateB) = (evalInt evalBest, evalMate evalBest) 286 | 287 | evalInt :: Stockfish.Evaluation -> Maybe Int 288 | evalInt (Right n) = Just n 289 | evalInt (Left _) = Nothing 290 | 291 | evalMate :: Stockfish.Evaluation -> Maybe Int 292 | evalMate (Right _) = Nothing 293 | evalMate (Left n) = Just n 294 | 295 | dbGameToPGN :: Game -> Maybe Pgn.Game 296 | dbGameToPGN game = 297 | rightToMaybe $ 298 | Logic.gameFromStart Pgn.pgnToMove $ Pgn.unsafeMoves $ Te.pack $ gamePgn game 299 | 300 | toPosAttribute :: Key Position -> Metrics.StatType -> Int -> PositionAttribute 301 | toPosAttribute pos stat = PositionAttribute pos (fromEnum stat) 302 | 303 | gsToPosHelper :: Logic.GameState -> DataAction [PositionAttribute] 304 | gsToPosHelper gs = do 305 | pos <- insertBy $ Position $ Logic.gameStateToFen gs 306 | return $ either (const []) (gsToPosAttributes gs) pos 307 | 308 | gsToPosAttributes :: Logic.GameState -> Key Position -> [PositionAttribute] 309 | gsToPosAttributes gs pos = attributes 310 | where attributes = fmap (uncurry (toPosAttribute pos)) stats 311 | stats = (Metrics.gameStateData . Metrics.getStats) gs 312 | 313 | obtainGameAttributes :: Entity Game -> DataAction [[PositionAttribute]] 314 | obtainGameAttributes dbGame = do 315 | let maybeGame = dbGameToPGN $ entityVal dbGame 316 | maybe (return []) (mapM gsToPosHelper . Logic.gameStates) maybeGame 317 | 318 | storeGameAttributes :: Entity Game -> DataAction () 319 | storeGameAttributes dbGame = do 320 | attrs :: [[PositionAttribute]] <- obtainGameAttributes dbGame 321 | mapM_ insertBy $ concat attrs 322 | 323 | storePositionAttribute :: PositionAttribute -> DataAction () 324 | storePositionAttribute pa = void $ insertBy pa 325 | 326 | deleteAtt :: DataAction () 327 | deleteAtt = do 328 | deleteWhere ([] :: [Filter PositionAttribute]) 329 | deleteWhere ([] :: [Filter Position]) 330 | return () 331 | 332 | storeAtt :: Int -> Int -> DataAction () 333 | storeAtt start num = do 334 | games :: [Entity Game] <- selectList [] [] 335 | let g = take num $ drop start games 336 | mapM_ storeGameAttributes g 337 | 338 | inb :: String -> DataAction a -> IO a 339 | inb name = inBackend $ DatabaseHelpers.connString name 340 | -------------------------------------------------------------------------------- /src/Test/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module Test.Helpers 9 | ( inBackend 10 | , DataAction 11 | , formatForDB 12 | , deleteDBContents 13 | ) where 14 | 15 | import Control.Monad.IO.Class (liftIO) 16 | import Control.Monad.Logger (NoLoggingT, runStderrLoggingT) 17 | import Control.Monad.Trans.Reader (ReaderT) 18 | import Control.Monad.Trans.Resource (ResourceT) 19 | import qualified Data.ByteString.Char8 as B 20 | import Database.Persist (Filter, deleteWhere) 21 | import Database.Persist.Postgresql as PsP 22 | ( SqlBackend 23 | , runMigration 24 | , runMigrationSilent 25 | , runSqlPersistMPool 26 | , withPostgresqlPool 27 | ) 28 | 29 | import qualified Chess.Pgn.Logic as Pgn 30 | 31 | import Services.Types 32 | 33 | -- See https://stackoverflow.com/questions/34624469/crud-pattern-on-haskell-persistent 34 | type DataAction a = ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a 35 | 36 | inBackend :: String -> DataAction a -> IO a 37 | inBackend conn action = 38 | runStderrLoggingT $ 39 | withPostgresqlPool (B.pack conn) 1 $ \pool -> 40 | liftIO $ 41 | flip runSqlPersistMPool pool $ do 42 | runMigration migrateAll 43 | runMigrationSilent migrateAll 44 | action 45 | 46 | -- My goal: Use the `HasPersistPool` typeclass for all database actions. That 47 | -- unifies the code I run in Snap and in the general IO Monad 48 | 49 | deleteDBContents :: String -> IO () 50 | deleteDBContents conn = 51 | inBackend conn $ do 52 | deleteWhere ([] :: [Filter MoveEval]) 53 | deleteWhere ([] :: [Filter GameAttribute]) 54 | deleteWhere ([] :: [Filter PlayerRating]) 55 | deleteWhere ([] :: [Filter Game]) 56 | deleteWhere ([] :: [Filter Tournament]) 57 | deleteWhere ([] :: [Filter Player]) 58 | deleteWhere ([] :: [Filter DatabasePermission]) 59 | deleteWhere ([] :: [Filter Database]) 60 | return () 61 | 62 | formatForDB :: Pgn.PgnTag -> (String, String) 63 | formatForDB (Pgn.PgnEvent s) = ("Event", s) 64 | formatForDB (Pgn.PgnOther name s) = (name, s) 65 | formatForDB (Pgn.PgnDate s) = ("Date", s) 66 | formatForDB (Pgn.PgnSite s) = ("Site", s) 67 | formatForDB (Pgn.PgnRound s) = ("Round", show s) 68 | formatForDB (Pgn.PgnWhite player) = ("White", show player) 69 | formatForDB (Pgn.PgnBlack player) = ("White", show player) 70 | formatForDB (Pgn.PgnResult result) = ("White", show result) 71 | formatForDB (Pgn.PgnWhiteElo rating) = ("WhiteElo", show rating) 72 | formatForDB (Pgn.PgnBlackElo rating) = ("BlackElo", show rating) 73 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 2 | # A snapshot resolver dictates the compiler version and the set of packages 3 | # to be used for project dependencies. For example: 4 | # 5 | # resolver: lts-3.5 6 | # resolver: nightly-2015-09-21 7 | # resolver: ghc-7.10.2 8 | # resolver: ghcjs-0.1.0_ghc-7.10.2 9 | # resolver: 10 | # name: custom-snapshot 11 | # location: "./custom-snapshot.yaml" 12 | # resolver: lts-7.14 13 | resolver: lts-16.0 14 | 15 | # User packages to be built. 16 | # Various formats can be used as shown in the example below. 17 | # 18 | 19 | # subdirs: 20 | # - auto-update 21 | # - wai 22 | # 23 | # A package marked 'extra-dep: true' will only be built if demanded by a 24 | # non-dependency (i.e. a user package), and its test suites and benchmarks 25 | # will not be run. This is useful for tweaking upstream packages. 26 | # Dependency packages to be pulled from upstream that are not in the resolver 27 | # (e.g., acme-missiles-0.3) 28 | extra-deps: 29 | - ../haskell-chess 30 | - MissingH-1.4.3.0@sha256:efbbe7065e17bc01ed925593a0c5b5793ab857585a8e9d5015d0025e526ab55c,4702 31 | - Unique-0.4.7.9@sha256:a7e154cf6d05169777a1e54aadab24fb3a6eae3ee167e5e77d7ba96d182436c7,2064 32 | - heist-1.1.0.1@sha256:121288965f6c77b0d06a09c5d8a3b80f9a083830d06857555e99f10868b18dcb,9311 33 | - lens-tutorial-1.0.4@sha256:325b59b7658f035d11386589c57d603ee27573f191ed8380dc2a890102bfe143,1199 34 | - map-syntax-0.3@sha256:9b92c51bcaf1d55f60f8aaef9a96adb29acb77112631fa4110fd5dcae54be7a6,2420 35 | - servant-snap-0.9.0@sha256:c344c543c74fe09a4fe0ddbc0d8f4f8eca3d324ad86e102ccd36b930b3974c22,4542 36 | - snap-1.1.3.1@sha256:ad589f2838a10bde793150e113c147996ba9dc8b522f34d1eb3297493c8d2672,8901 37 | - snaplet-persistent-0.6.1@sha256:11eb1aa3735f258ae8c0248625608821e0babd68add446d18ee3b0e4a45876e3,2195 38 | - snaplet-postgresql-simple-1.2.0.0@sha256:07d73d1e0f3bf8a1b87a6ac9b9a69dc06867e4adb47f9abfed261a59326bf1ff,2827 39 | - template-0.2.0.10@sha256:f822de4d34c45bc84b33a61bc112c15fedee6fa6dc414c62b10456395a868f85,987 40 | - mime-mail-ses-0.4.3@sha256:eae01b3e80467ec280a4fb040d2618e371b96b14d58fff324ba35d337f5ec0f8,2271 41 | - pwstore-fast-2.4.4@sha256:9b6a37510d8b9f37f409a8ab3babac9181afcaaa3fce8ba1c131a7ed3de30698,1351 42 | - smtp-mail-0.3.0.0@sha256:2e6d9cb29d09a5a04d77a905eb1b570b94b5654e24d40630ea96aa374474c12f,1239 43 | - xmlhtml-0.2.5.2@sha256:3f0990f725551985d777e8edb5563fe99aee998f1fde6a7633f720f76df54701,46997 44 | - hspec-snap-1.0.2.0@sha256:e12318fccd6c698c2aee30bd55903198e575174a798a226916d359bde70d7aa8,2293 45 | - digestive-functors-0.8.4.2@sha256:badff1797b6dcd860a48ed4558985b2f6bec501e1016fa5afd9d7d6b0d8e4c08,3364 46 | 47 | # Override default flag values for local packages and extra-deps 48 | flags: {} 49 | 50 | # Extra package databases containing global packages 51 | extra-package-dbs: [] 52 | 53 | # Control whether we use the GHC we find on the path 54 | # system-ghc: true 55 | # 56 | # Require a specific version of stack, using version ranges 57 | # require-stack-version: -any # Default 58 | # require-stack-version: ">=1.1" 59 | # 60 | # Override the architecture used by stack, especially useful on Windows 61 | # arch: i386 62 | # arch: x86_64 63 | # 64 | # Extra directories used by stack for building 65 | # extra-include-dirs: [/path/to/dir] 66 | # extra-lib-dirs: [/path/to/dir] 67 | # 68 | # Allow a newer minor version of GHC than the snapshot specifies 69 | # compiler-check: newer-minor 70 | -------------------------------------------------------------------------------- /test/FillDB.hs: -------------------------------------------------------------------------------- 1 | module FillDB where 2 | 3 | import Options.Applicative 4 | 5 | import AppTypes 6 | import qualified Test.Fixtures as F 7 | 8 | dbTypeParser :: Parser String 9 | dbTypeParser = dbNameReader <$> switch (long "dev" <> short 't' <> help "Run test analysis") 10 | 11 | dbNameReader :: Bool -> String 12 | dbNameReader True = "dev" 13 | dbNameReader False = "prod" 14 | 15 | main :: IO () 16 | main = do 17 | settings <- execParser opts 18 | F.runJob settings 19 | return () 20 | 21 | parseSettings :: Parser F.FixtureSettings 22 | parseSettings = F.FixtureSettings 23 | <$> dbTypeParser 24 | <*> switch (long "runEval" <> short 'e' <> help "Run the evaluation") 25 | <*> switch (long "onlyContinueEval" <> short 'c' <> help "Only continue the evaluation") 26 | 27 | opts = info (parseSettings <**> helper) 28 | ( fullDesc 29 | <> progDesc "Haskell-chess" 30 | <> header "" ) 31 | 32 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies #-} 2 | -- import Test.HUnit 3 | import Test.Hspec 4 | import qualified Test.Hspec.Snap as Test 5 | import Snap.Core 6 | import Snap.Snaplet 7 | import Control.Monad.IO.Class (MonadIO, liftIO) 8 | import Control.Monad (unless) 9 | import qualified Data.ByteString.Char8 as B 10 | import Snap.Snaplet.Auth 11 | import Database.Persist as P 12 | import Database.Persist.Sql 13 | import Snap.Snaplet.Persistent 14 | import Database.Esqueleto 15 | import Data.Either 16 | import Data.Text as T (Text, pack) 17 | import Data.List as L 18 | import Data.Aeson 19 | import Data.Maybe as M 20 | import Data.Aeson.Types 21 | import Data.Time 22 | import Data.Time.Clock.POSIX 23 | import Data.Either.Combinators (rightToMaybe) 24 | import Control.Monad (void, when) 25 | 26 | import Services.Helpers 27 | import Test.Helpers as H 28 | import Services.Service as S 29 | import Services.DatabaseHelpers as DBH 30 | import Services.Types 31 | import Services.Openings 32 | import qualified Test.Fixtures as Fix 33 | import Snap.Snaplet.Session (commitSession) 34 | 35 | import Data.Attoparsec.Text (parseOnly) 36 | 37 | import AppTypes 38 | import qualified Application as App 39 | 40 | main = hspec $ do 41 | testOpening 42 | testUserHandling 43 | testApi 44 | 45 | dbName :: String 46 | dbName = "test" 47 | 48 | connStringTest = DBH.connString dbName 49 | inBackendTest = H.inBackend connStringTest 50 | 51 | settings = getSettings Test 52 | 53 | toTop :: Handler App.App (S.Service App.App) r -> Handler App.App App.App r 54 | toTop = withTop App.service 55 | 56 | insertUserData userName = do 57 | let backendInsert row = liftIO $ inBackendTest $ P.insert row 58 | loginForApi userName 59 | user <- fromMaybe "" <$> toTop S.currentUserName 60 | 61 | db :: Key Database <- backendInsert $ Database ("temp" ++ userName) False (Just user) 62 | dbp <- backendInsert $ DatabasePermission db user True True True 63 | p <- backendInsert $ Player db "temp" "temp" 64 | t <- backendInsert $ Tournament db "temp" 65 | game <- backendInsert $ Game db p p 1 t "" Nothing Nothing 66 | ga <- backendInsert $ GameAttribute game "test" "test" 67 | 68 | return db 69 | 70 | nothingHandlerTest = toTop S.nothingHandler 71 | 72 | loginAsAnotherRandomUser = do 73 | userName <- liftIO getTimeString 74 | loginForApi userName 75 | 76 | 77 | getDBResults handler modifierAfterwards getKeys = Test.eval $ do 78 | userName <- liftIO getTimeString 79 | db <- insertUserData userName 80 | modifierAfterwards 81 | res <- toTop handler 82 | let keyUser = dbKeyInt db 83 | let filtered = filter (==keyUser) $ fmap getKeys res 84 | return $ length filtered 85 | 86 | testApi :: Spec 87 | testApi = Test.snap (route (App.routes True)) (App.app settings) $ beforeAll_ doIO $ do 88 | 89 | describe "In the database functions," $ do 90 | 91 | it "the databases functions returns the personal DB if logged in" $ do 92 | overlap <- getDBResults S.getDatabases nothingHandlerTest (dbKeyInt . entityKey) 93 | Test.shouldEqual overlap 1 94 | 95 | it "the databases functions does not return the personal DB if logged out" $ do 96 | overlap <- getDBResults S.getDatabases App.resetUser (dbKeyInt . entityKey) 97 | Test.shouldEqual overlap 0 98 | 99 | it "the database stats functions returns the personal DB if logged in" $ do 100 | overlap <- getDBResults S.getDatabaseStats nothingHandlerTest (dbResultId . dbResultNumbers) 101 | Test.shouldEqual overlap 1 102 | 103 | it "the database stats functions does not return the personal DB if logged out" $ do 104 | overlap <- getDBResults S.getDatabaseStats App.resetUser (dbResultId . dbResultNumbers) 105 | Test.shouldEqual overlap 0 106 | 107 | it "the database stats functions does not return the personal DB if logged in as another user" $ do 108 | overlap <- getDBResults S.getDatabaseStats loginAsAnotherRandomUser (dbResultId . dbResultNumbers) 109 | Test.shouldEqual overlap 0 110 | 111 | it "the eval averages are returned for every player" $ do 112 | (dbId, players, dbGames) <- playerGameData dbName 113 | res <- Test.eval $ toTop $ S.gameEvaluations $ S.GameRequestData (dbKeyInt dbId) [] 114 | Test.shouldEqual (L.length res) (L.length players) 115 | 116 | it "one should only get games for the private databases that a user owns" $ do 117 | userName :: String <- liftIO getTimeString 118 | 119 | (games, gamesForNewUser) <- Test.eval $ do 120 | db <- insertUserData userName 121 | let request = toTop $ S.getGames $ GameRequestData (dbKeyInt db) [] 122 | games :: [GameDataFormatted] <- request 123 | loginForApi $ userName ++ "_new" 124 | gamesForNewUser <- request 125 | return (games, gamesForNewUser) 126 | 127 | Test.shouldNotEqual games gamesForNewUser 128 | Test.shouldEqual (L.length games) 1 129 | Test.shouldEqual (L.length gamesForNewUser) 0 130 | 131 | describe "In the API," $ do 132 | 133 | it "databases should return what's public in the table" $ do 134 | -- Logging in as a user that doesn't own any databases 135 | userName <- liftIO getTimeString 136 | apiDatabases <- Test.eval $ do 137 | loginForApi userName 138 | toTop S.getDatabases 139 | dbDatabases :: [Entity Database] <- liftIO $ inBackendTest $ selectList [(P.==.) DatabaseIsPublic True] [] 140 | Test.shouldEqual (L.length apiDatabases) (L.length dbDatabases) 141 | 142 | describe "If I query the function to get games then" $ do 143 | 144 | it "it doesn't return anything for a non-existent database" $ do 145 | dbDatabases :: [Entity Database] <- liftIO $ inBackendTest $ selectList [] [] 146 | dbTournaments :: [Entity Tournament] <- liftIO $ inBackendTest $ selectList [] [] 147 | let nonExistingDB = L.maximum (fmap dbKey dbTournaments) + 1 148 | let tournamentIds = fmap dbKey dbTournaments 149 | let requestData = GameRequestData nonExistingDB tournamentIds 150 | res :: [GameDataFormatted] <- Test.eval $ toTop $ S.getGames requestData 151 | Test.shouldEqual (L.length res) 0 152 | 153 | it "it does return values for a database that has games" $ do 154 | dbDatabases :: [Entity Database] <- liftIO $ inBackendTest $ selectList [] [] 155 | dbTournaments :: [Entity Tournament] <- liftIO $ inBackendTest $ selectList [] [] 156 | dbGames :: [Entity Game] <- liftIO $ inBackendTest $ selectList [] [] 157 | Test.shouldBeTrue (length dbGames > 0) 158 | let firstGame = L.head dbGames 159 | let gamesForDB = L.filter (\v -> gameDatabaseId (entityVal v) == gameDatabaseId (entityVal firstGame)) dbGames 160 | let firstGameInt = L.head $ catMaybes $ fmap keyInt $ P.keyToValues $ gameDatabaseId $ entityVal firstGame 161 | let tournamentIds = fmap dbKey dbTournaments 162 | let requestData = GameRequestData firstGameInt tournamentIds 163 | res <- Test.eval $ toTop $ S.getGames requestData 164 | Test.shouldEqual (L.length res) (L.length gamesForDB) 165 | 166 | 167 | -- Setting up the database fixtures. This function is time-intensive, and run 168 | -- once before a set of tests is executed. These tests do not modify the data. 169 | -- Thus we want to set up this function that re-running it doesn't delete and 170 | -- re-insert the data, which shortens the time for running the tests 171 | 172 | doIO :: IO () 173 | doIO = do 174 | let dbName = "test" 175 | dbDatabases :: [Entity Database] <- inBackendTest $ selectList [] [] 176 | 177 | let alreadyRun = False -- length dbDatabases > 0 178 | let runEval = True 179 | let onlyContinueEval = False 180 | let settings = Fix.FixtureSettings dbName runEval onlyContinueEval 181 | unless alreadyRun $ Fix.runJob settings 182 | return () 183 | 184 | defaultDBName = "dummy games" 185 | 186 | getDefaultDBId = fmap (P.entityKey . L.head) $ liftIO $ inBackendTest $ selectList [(P.==.) DatabaseName defaultDBName] [] 187 | 188 | expectedTest text expected parse = do 189 | let result = parseOnly parse $ pack text 190 | result `shouldBe` expected 191 | 192 | 193 | playerGameData dbName = do 194 | defaultDBId <- getDefaultDBId 195 | players :: [Entity Player] <- liftIO $ inBackendTest $ selectList [(P.==.) PlayerDatabaseId defaultDBId] [] 196 | dbGames :: [Entity Game] <- liftIO $ inBackendTest $ selectList [(P.==.) GameDatabaseId defaultDBId] [] 197 | return (defaultDBId, players, dbGames) 198 | 199 | testOpening :: Spec 200 | testOpening = describe "The opening module" $ do 201 | 202 | it "can correctly parse the code" $ 203 | expectedTest "A00" (Right "A00") openingCodeParser 204 | 205 | it "can parse a simple opening name" $ 206 | expectedTest "Test' Opening" (Right "Test' Opening") openingNameParser 207 | 208 | it "can parse a incorrect opening name" $ 209 | expectedTest "Test' Opening\n" (Right "Test' Opening") openingNameParser 210 | 211 | it "can parse an opening name with comments" $ 212 | expectedTest "Test' Opening; comments" (Right "Test' Opening") openingNameParser 213 | 214 | it "can parse a game move" $ 215 | expectedTest "1. e4 1/2" (Right "1. e4") openMoveParser 216 | 217 | it "can parse the game list" $ 218 | expectedTest "A00 A\n1.a3 1/2" (Right (ListData "A00" "A" "1.a3")) parseListData 219 | 220 | it "can parse the game list with newlines" $ 221 | expectedTest "A00 A\n1.a3 1/2\n\n\n" (Right (ListData "A00" "A" "1.a3")) parseListData 222 | 223 | getTimeString :: IO String 224 | getTimeString = fmap show getTimeInt 225 | 226 | getTimeInt :: IO Int 227 | getTimeInt = getCurrentTime >>= pure . (1000*) . utcTimeToPOSIXSeconds >>= pure . round 228 | 229 | getParams :: IO [(B.ByteString, B.ByteString)] 230 | getParams = do 231 | userName :: String <- liftIO getTimeString 232 | return [("login", B.pack userName), ("password", "password")] 233 | 234 | loginForApi userName = toTop $ do 235 | S.createFullUser userName "password" 236 | S.forceLoginFromEmail userName 237 | 238 | instance Test.HasSession App.App where 239 | getSessionLens = App.sess 240 | 241 | loginModifier userName h = do 242 | loginForApi userName 243 | h 244 | 245 | testUserHandling :: Spec 246 | testUserHandling = Test.snap (route (App.routes True)) (App.app settings) $ do 247 | describe "In the user handling ," $ do 248 | it "getting user name works" $ do 249 | userName :: String <- liftIO getTimeString 250 | res <- Test.eval $ do 251 | loginForApi userName 252 | toTop S.currentUserName 253 | Test.shouldEqual res (Just userName) 254 | 255 | it "running createFullUser adds an AppUser" $ do 256 | userName :: String <- liftIO getTimeString 257 | dbUsersBefore :: [Entity AppUser] <- liftIO $ inBackendTest $ selectList [] [] 258 | Test.eval $ toTop $ S.createFullUser userName "password" 259 | dbUsersAfter :: [Entity AppUser] <- liftIO $ inBackendTest $ selectList [] [] 260 | Test.shouldEqual ((length dbUsersBefore) + 1) (length dbUsersAfter) 261 | 262 | it "changing user works" $ do 263 | userName :: String <- liftIO getTimeString 264 | let userName2 = userName ++ "test" 265 | 266 | runUser <- Test.eval $ do 267 | loginForApi userName 268 | loginForApi userName2 269 | toTop S.currentUserName 270 | 271 | Test.shouldEqual (Just userName2) runUser 272 | -------------------------------------------------------------------------------- /test/wipe_table.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | psql -U postgres -d chess < wipe_table.sql 4 | -------------------------------------------------------------------------------- /test/wipe_table.sql: -------------------------------------------------------------------------------- 1 | drop table if exists game; 2 | drop table if exists app_user; 3 | drop table if exists database; 4 | drop table if exists important_move; 5 | drop table if exists "user"; 6 | 7 | --------------------------------------------------------------------------------