tjhintz/farm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Using sqlite database, mt proctor animation.

Browse Source
This commit is contained in:
Thomas Hintz
2020-04-09 22:52:44 -07:00
parent b34a66f697
commit 6ff6387fef
31 changed files with 1525 additions and 280 deletions
Download Patch File Download Diff File Expand all files Collapse all files

134
src/server/db.scm Normal file
View File

@@ -0,0 +1,134 @@
(use sql-de-lite crypt)
(define *db* "/home/tjhintz/db")
(define-syntax with-db
(syntax-rules ()
((_ (var) body ...)
(call-with-database *db*
(lambda (var)
body ...)))))
(define (create-tables)
(with-db (db)
(exec (sql db "create table users(id INTEGER PRIMARY KEY, username TEXT, email TEXT, password TEXT, salt TEXT);"))
(exec (sql db "create table sessions(bindings TEXT, session_id TEXT PRIMARY KEY);"))
(exec (sql db "create table games(id INTEGER PRIMARY KEY, status TEXT, object TEXT);"))
(exec (sql db "create table players(id INTEGER PRIMARY KEY, object TEXT);"))
(exec (sql db "create table user_games(user_id INTEGER, game_id INTEGER);"))))
(define (db-session-set! sid bindings)
(with-db (db)
(exec (sql db "insert or replace into sessions(bindings, session_id) values (?, ?);")
(with-output-to-string (lambda () (write bindings)))
sid)))
(define (db-session-ref sid)
(with-input-from-string
(or (alist-ref
'bindings
(with-db (db)
(query fetch-alist
(sql db "select * from sessions where session_id=?;")
sid)))
"#f")
read))
(define (add-user username email password)
(let ((salt (crypt-gensalt)))
(with-db (db)
(exec (sql db "insert into users(username, password, salt, email) values(?, ?, ?, ?);")
username (crypt password salt) salt email)
(last-insert-rowid db))))
(define (fetch-user username)
(with-db (db)
(query fetch-alist
(sql db "select * from users where username=?;")
username)))
(define (fetch-user-by-id id)
(with-db (db)
(query fetch-alist
(sql db "select * from users where id=?;")
id)))
(define (valid-password? username password)
(and-let* ((user (fetch-user username))
(_ (if (null? user)
(begin (crypt password "$2a$12$OW1wyLclJvq.PIxgoHCjdu")
#f)
#t)))
(string=? (crypt password (alist-ref 'salt user))
(alist-ref 'password user))))
(define (alist->string alist)
(with-output-to-string (lambda () (write alist))))
(define (string->alist s)
(with-input-from-string s read))
(define (db-add-game status object)
(with-db (db)
(exec (sql db "insert into games(status, object) values (?, ?);")
status (alist->string object))
(last-insert-rowid db)))
(define (db-update-game id status object)
(with-db (db)
(exec (sql db "replace into games(id, status, object) values (?, ?, ?);")
id status (alist->string object))))
(define (db-fetch-game id)
(string->alist
(with-db (db)
(query fetch-value
(sql db "select object from games where id=?;")
id))))
(define (db-fetch-open-games)
(map
string->alist
(with-db (db)
(query fetch-column
(sql db "select object from games where status=?;")
"pre-game"))))
(define (db-fetch-game-row id)
(let ((res
(with-db (db)
(query fetch-alist
(sql db "select * from games where id=?;")
id))))
`((id . ,(alist-ref 'id res))
(status . ,(alist-ref 'status res))
(object . ,(string->alist (alist-ref 'object res))))))
(define (db-add-player object)
(with-db (db)
(exec (sql db "insert into players(object) values (?);")
(alist->string object))
(last-insert-rowid db)))
(define (db-update-player id object)
(with-db (db)
(exec (sql db "replace into players(id, object) values (?, ?);")
id (alist->string object))))
(define (db-fetch-player id)
(string->alist
(with-db (db)
(query fetch-value
(sql db "select object from players where id=?;")
id))))
(define (db-add-user-game user-id game-id)
(with-db (db)
(exec (sql db "insert into user_games(user_id, game_id) values (?, ?);")
user-id game-id)))
(define (db-fetch-user-games user-id)
(with-db (db)
(query fetch-column
(sql db "select game_id from user_games where user_id=?;")
user-id)))

283
src/server/farm.scm
View File

@@ -29,6 +29,33 @@
(else
(include "game")))
(include "db.scm")
(session-storage-initialize
(lambda ()
'no-op))
(session-storage-set!
(lambda (sid session-item)
(db-session-set! sid (session-item-bindings session-item))))
(define (expiration)
(+ (current-milliseconds)
(inexact->exact (floor (* (session-lifetime) 1000)))))
(session-storage-ref
(lambda (sid)
(let ((data (db-session-ref sid)))
(if data
(make-session-item (expiration) (remote-address) data #f)
(error "session not found")))
;; (make-session-item (+ (current-milliseconds) 100000000) (remote-address) `((user-id . ,(db-session-ref sid))) #f)
))
(session-storage-delete!
(lambda (sid)
(error "session storage delete not handled")))
(root-path "./")
(define (neq? a b) (not (eq? a b)))
@@ -55,6 +82,7 @@
(SRV:send-reply (pre-post-order* sxml rules)))))))
(define *game* (make-parameter #f))
(define *player* (make-parameter #f))
(define-syntax safe-set!
(ir-macro-transformer
@@ -90,6 +118,7 @@
(next-year-rules initform: '() accessor: player-next-year-rules)
(color initform: #f accessor: player-color)
(name initform: "PLAYER X" accessor: player-name)
(user-id initform: #f accessor: player-user-id)
(trade initform: '() accessor: player-trade)
(last-updated initform: 0 accessor: player-last-updated)
(last-cash initform: 5000 accessor: player-last-cash)
@@ -114,7 +143,7 @@
(colors initform: '() accessor: game-colors)
(last-updated initform: 0 accessor: game-last-updated)
(called-audit initform: #f accessor: game-called-audit)
(state initform: 'playing accessor: game-state)
(state initform: 'pre-game accessor: game-state)
(name initform: "game" accessor: game-name)
(turn initform: 1 accessor: game-turn)
(current-player initform: #f accessor: game-current-player)
@@ -154,6 +183,7 @@
(next-year-rules . ,(player-next-year-rules player))
(color . ,(player-color player))
(name . ,(player-name player))
(user-id . ,(player-user-id player))
(trade . ())
(last-updated . 0)
(last-cash . ,(player-cash player))
@@ -196,11 +226,11 @@
*operating-expense-cards*)))
'called-audit (if (alist-ref 'called-audit x)
(find (lambda (p)
(string=? (player-name p) (alist-ref 'called-audit x)))
(equal? (player-name p) (alist-ref 'called-audit x)))
players)
#f)
'current-player (find (lambda (p)
(string=? (player-name p) (alist-ref 'current-player x)))
(equal? (player-name p) (alist-ref 'current-player x)))
players)
(fold (lambda (k r) (cons k (cons (alist-ref k x) r)))
'()
@@ -221,6 +251,10 @@
(lambda ()
(write (app->sexp *app*)))))
(define (save-game game)
(db-update-game (game-id game) (symbol->string (game-state game))
(game->sexp game)))
(define (load-app)
(with-input-from-file "/home/tjhintz/app.scm"
(lambda ()
@@ -236,7 +270,7 @@
(fold (lambda (k r) (cons k (cons (alist-ref k x) r)))
'()
'(cash debt space previous-space state assets ridges
harvest-mult otbs
harvest-mult otbs user-id
year-rules next-year-rules hay-doubled corn-doubled
color name trade last-updated last-cash))))
@@ -310,13 +344,14 @@
(safe-set! (game-colors game) (cdr (game-colors game)))
color))
(define (add-player-to-game game color name)
(define (add-player-to-game game color name user-id)
(let ((player (make <player>
'cash (game-setting 'starting-cash game)
'display-cash (game-setting 'starting-cash game)
'debt (game-setting 'starting-debt game)
'color color
'name name
'user-id user-id
'state (if (= (length (game-players game)) 0)
'pre-turn 'turn-ended))))
(safe-set! (game-players game) (append (game-players game) (list player)))
@@ -441,6 +476,7 @@
(player-otbs p))))
(color . ,(symbol->string (player-color p)))
(name . ,(player-name p))
(user-id . ,(player-user-id p))
(trade . ,(player-trade p))
(lastCash . ,(player-last-cash p))
(hayDoubled . ,(player-hay-doubled p))
@@ -459,6 +495,7 @@
(player-otbs p))))
(color . ,(symbol->string (player-color p)))
(name . ,(player-name p))
(user-id . ,(player-user-id p))
(trade . ,(player-trade p))
(lastCash . ,(player-last-cash p))
(hayDoubled . ,(player-hay-doubled p))
@@ -535,13 +572,23 @@
(define (finish-year player #!optional (collect-wages #t))
(let ((game (*game*)))
(when collect-wages
(safe-set! (player-cash player)
(+ (player-cash player) 5000))
(safe-set! (player-display-cash player) (player-cash player))
(safe-set! (game-actions game)
(cons '((?action . info)
(?value . "You earned $5,000 from your city job!"))
(game-actions game))))
(let* ((richest (car (sort (game-players game)
(lambda (p1 p2)
(> (player-net-worth p1)
(player-net-worth p2))))))
(bonus (max (farming-round
(* (- (player-net-worth richest)
(player-net-worth player))
0.2))
2500)))
(safe-set! (player-cash player)
;; (+ (player-cash player) 5000)
(+ (player-cash player) bonus))
(safe-set! (player-display-cash player) (player-cash player))
(safe-set! (game-actions game)
(cons `((?action . info)
(?value . ,(conc "You earned $" bonus " from your city job!")))
(game-actions game)))))
(when (game-called-audit game)
(safe-set! (game-actions game)
(append (game-actions game)
@@ -810,7 +857,7 @@
(player->list player)
(game->list (*game*) player)))
(define (create-start-response event)
(define (create-start-response event #!key (errors '()))
`((event . ,event)
(games . ((games . ,(list->vector
(map (lambda (game)
@@ -820,7 +867,24 @@
(map symbol->string (game-colors game))))
(players . ,(list->vector
(map player-name (game-players game))))))
(app-games *app*))))))))
(map (lambda (gid)
(sexp->game (db-fetch-game gid)))
(db-fetch-user-games (session-ref (sid) 'user-id -1))))))))
(openGames . ((games . ,(list->vector
(map (lambda (game)
`((name . ,(game-name game))
(id . ,(game-id game))
(colors . ,(list->vector
(map symbol->string (game-colors game))))
(players . ,(list->vector
(map player-name (game-players game))))))
(map sexp->game (db-fetch-open-games)))))))
(user . ,(let ((id (session-ref (sid) 'user-id #f)))
(if (and id (not (equal? id -1)))
id
#f)))
(errors . ,(list->vector errors))))
(define (message-players! game player message #!key (type "action"))
(for-each (lambda (p)
(when (not (eq? p player))
@@ -855,13 +919,35 @@
(safe-set! (player-display-cash player) (player-cash player)))
(game-players game))))
(define (find-game id)
(let ((game-in-memory (find (lambda (g) (= (game-id g) id))
(app-games *app*))))
(if game-in-memory
game-in-memory
(let ((db-game (sexp->game (db-fetch-game id))))
(push! db-game (app-games *app*))
db-game))))
(define (next-roll last-roll)
(let ((roll (+ (random 6) 1)))
(if (= roll last-roll)
(next-roll last-roll)
roll)))
(define (make-rolls n)
(define (_make-rolls n i rolls)
(if (<= i n)
(_make-rolls n (+ i 1) (cons (next-roll (car rolls)) rolls))
rolls))
(_make-rolls n 1 (list (next-roll -1))))
(define (process-message player game type msg)
(when game
(safe-set! (game-messages game) '())
(when player
(safe-set! (player-last-cash player) (player-cash player)))
(print "message type: " type)
(cond ((string=? type "roll")
(let ((num (+ (random 6) 1)))
(let ((num (+ (random 6) 1))
(rolls (make-rolls 22)))
(when *next-roll* (set! num *next-roll*))
(safe-set! (player-previous-space player)
(player-space player))
@@ -876,7 +962,8 @@
(finish-year player))
(safe-set! (player-harvest-mult player) 1)
(let ((resp `((from . ,(player-previous-space player))
(to . ,(player-space player)))))
(to . ,(player-space player))
(rolls . ,(list->vector rolls)))))
(safe-set! (game-actions game)
(append (game-actions game)
`(((?action . move) (?value . ,resp))
@@ -1169,7 +1256,7 @@
(print exn)
(print-error-message exn)
(print "error saving app"))
(save-app))
(save-game game))
(if (eq? (game-state game) 'finished)
(do-end-of-game game)
(message-players! game player '() type: "update"))
@@ -1180,6 +1267,7 @@
(create-start-response "start-init"))
((string=? type "new-game")
(let* ((color (string->symbol (alist-ref 'checkedColor msg)))
(user (fetch-user-by-id (session-ref (sid) 'user-id)))
(game (make <game> 'colors (filter (cut neq? <> color)
'(green red blue yellow black))
'name (alist-ref 'gameName msg)
@@ -1200,49 +1288,81 @@
(trade . ,(or (alist-ref 'trade msg) #t)))))
(player (add-player-to-game game
color
(alist-ref 'playerName msg)))
(alist-ref 'username user)
(alist-ref 'id user)))
;; (ai-player (add-ai-to-game game 'red "AI Player 1"))
)
(push! game (app-games *app*))
(session-set! (sid) 'player player)
(session-set! (sid) 'game game)
(let ((gid (db-add-game "pre-game" (game->sexp game))))
(safe-set! (game-id game) gid)
(db-update-game gid "pre-game" (game->sexp game))
(db-add-user-game (alist-ref 'id user) (game-id game))
(session-set! (sid) 'game-id (game-id game)))
(*game* game)
(*player* player)
(set-startup-otbs game player 2)
;; (set-startup-otbs game ai-player 2)
;; (thread-start! (make-ai-push-receiver game ai-player))
(create-start-response "new-game-started")))
((string=? type "join-game")
(let* ((name (alist-ref 'gameName msg))
(let* ((user (fetch-user-by-id (session-ref (sid) 'user-id)))
(name (alist-ref 'username user))
(id (alist-ref 'gameId msg))
(game (find (lambda (g) (= (game-id g) id))
(app-games *app*)))
(game (find-game id))
(color-raw (string->symbol (alist-ref 'checkedColor msg)))
(color (if (not (member color-raw (game-colors game)))
(car (game-colors game))
color-raw))
(player (add-player-to-game game
color
(alist-ref 'playerName msg))))
(alist-ref 'username user)
(alist-ref 'id user))))
(safe-set! (game-colors game) (filter (cut neq? <> color) (game-colors game)))
(session-set! (sid) 'player player)
(session-set! (sid) 'game game)
(session-set! (sid) 'game-id (game-id game))
(db-add-user-game (alist-ref 'id user) (game-id game))
(*game* game)
(*player* player)
(set-startup-otbs game player 2)
(message-players! game player '() type: "update")
(create-start-response "new-game-started")))
((string=? type "join-as-existing")
(let* ((name (alist-ref 'gameName msg))
(pname (alist-ref 'playerName msg))
(id (alist-ref 'gameId msg))
(game (find (lambda (g) (= (game-id g) id))
(app-games *app*)))
(player (find (lambda (p) (string=? (player-name p) pname))
(let* ((id (alist-ref 'gameId msg))
(user-id (session-ref (sid) 'user-id))
(game (find-game id))
(player (find (lambda (p) (equal? (player-user-id p) user-id))
(game-players game))))
(session-set! (sid) 'player player)
(session-set! (sid) 'game game)
(*game* game)
(*player* player)
(create-start-response "new-game-started")))
))
((string=? type "create-account")
(let ((username (alist-ref 'username msg))
(email (alist-ref 'email msg))
(password (alist-ref 'password msg))
(confirm-password (alist-ref 'confirmPassword msg)))
(if (string=? password confirm-password)
(if (null? (fetch-user username))
(let ((id (add-user username email password)))
(session-set! (sid) 'user-id id)
(create-start-response "start-init"))
(create-start-response "start-init" errors: '("Account already exists")))
(create-start-response "start-init" errors: '("Passwords don't match")))))
((string=? type "login")
(let ((username (alist-ref 'username msg))
(password (alist-ref 'password msg)))
(if (valid-password? username password)
(begin (session-set! (sid) 'user-id (alist-ref 'id (fetch-user username)))
(create-start-response "start-init"))
(create-start-response "start-init" errors: '("Invalid password or account doesn't exist")))))
((string=? type "logout")
(session-set! (sid) 'game-id #f)
(session-set! (sid) 'user-id #f)
(create-start-response "start-init"))
((string=? type "start-game")
(safe-set! (game-state (*game*)) 'pre-turn)
(db-update-game (game-id (*game*)) (symbol->string (game-state (*game*)))
(game->sexp (*game*)))
(message-players! (*game*) (*player*) '() type: "update")
(create-ws-response (*player*) "update" '()))))
(define (process-ai-push-message player game msg)
(print (player-name player))
@@ -1297,6 +1417,18 @@
(process-ai-push-message player game msg)
(loop (mailbox-receive! (player-mailbox player))))))
(define (session-game)
(let ((user-id (session-ref (sid) 'user-id)))
(if (and (not (*game*)) (session-ref (sid) 'game-id #f))
(let ((possible-game (find-game (session-ref (sid) 'game-id))))
(when possible-game
(*game* possible-game)
(*player* (find (lambda (p)
(equal? (player-user-id p) user-id))
(game-players (*game*))))
(*game*)))
(and (*game*)))))
(define (websocket-page)
(sid (read-cookie (session-cookie-name)))
;; TODO some kind of error handling if (sid) #f
@@ -1321,16 +1453,28 @@
(print-call-chain)
(print-error-message exn))))
(event . "error"))
(let* ((game (session-ref (sid) 'game #f))
(player (session-ref (sid) 'player #f))
(res (process-message player
(session-game)
(let* ((game (*game*))
(res (process-message (*player*)
game
(alist-ref 'type msg)
msg)))
(when game
(safe-set! (game-last-updated game) (+ (game-last-updated game) 1))
(safe-set! (player-last-updated player) (game-last-updated game)))
res)))))
(when (*player*)
(safe-set! (player-last-updated (*player*)) (game-last-updated game))))
res)
;; (let* ((game (session-ref (sid) 'game #f))
;; (player (session-ref (sid) 'player #f))
;; (res (process-message player
;; game
;; (alist-ref 'type msg)
;; msg)))
;; (when game
;; (safe-set! (game-last-updated game) (+ (game-last-updated game) 1))
;; (safe-set! (player-last-updated player) (game-last-updated game)))
;; res)
))))
(loop (read-json (receive-message)))))))
(define (push-websocket-page)
@@ -1338,39 +1482,33 @@
;; TODO some kind of error handling if (sid) #f
(with-concurrent-websocket
(lambda ()
(let ((game (session-ref (sid) 'game))
(player (session-ref (sid) 'player)))
(*game* game)
(let loop ((msg (mailbox-receive! (player-mailbox player))))
(print msg)
(when (not game)
(set! game (session-ref (sid) 'game)))
(when (not player)
(set! player (session-ref (sid) 'player)))
;; when (< (player-last-updated player)
;; (game-last-updated game))
(handle-exceptions
exn
(send-message
(json->string
(session-game)
(let loop ((msg (mailbox-receive! (player-mailbox (*player*)))))
(session-game)
;; when (< (player-last-updated player)
;; (game-last-updated game))
(handle-exceptions
exn
(send-message
(json->string
`((exn . ,(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn)))))))
(send-message
(json->string
(handle-exceptions
exn
`((exn . ,(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn)))))))
(send-message
(json->string
(handle-exceptions
exn
`((exn . ,(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn))))
(event . "error"))
(create-ws-response player
(alist-ref 'type msg)
(alist-ref 'value msg))
))))
(loop (mailbox-receive! (player-mailbox player))))))))
(print-error-message exn))))
(event . "error"))
(create-ws-response (*player*)
(alist-ref 'type msg)
(alist-ref 'value msg))
))))
(loop (mailbox-receive! (player-mailbox (*player*))))))))
(define (otb-spec->otb-cards spec id)
`((contents . ,(sxml->html* (list-ref spec 5)))
@@ -2034,6 +2172,7 @@
(game-players game)))))
((alist-ref 'action operating-expense) player)
`((rolled . ,rolled)
(rolls . ,(list->vector (make-rolls 22)))
(income . ,income)
(harvestMult . ,harvest-mult)
(operatingExpense . ,(alist-ref 'contents operating-expense))