├── .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 |
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 |
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 |
--------------------------------------------------------------------------------