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

Better error handling, birthdays, startup otbs, resource caching.

Browse Source
This commit is contained in:
Thomas Hintz
2020-04-15 08:47:13 -07:00
parent 197e4ffc5d
commit 333bd70d1a
13 changed files with 536 additions and 177 deletions
Download Patch File Download Diff File Expand all files Collapse all files

357
src/server/farm.scm
View File

@@ -18,7 +18,7 @@
;;; <https://www.gnu.org/licenses/>.
(import chicken scheme srfi-1 data-structures)
(use http-session srfi-69 coops uri-common
(use http-session srfi-69 coops coops-utils uri-common
srfi-18 medea numbers spiffy spiffy-cookies
intarweb pll sxml-transforms websockets miscmacros
mailbox)
@@ -156,7 +156,8 @@
(audit-threshold . 250000)
(starting-cash . 5000)
(starting-debt . 5000)
(trade . #t))
(trade . #t)
(starting-otbs . 2))
accessor: game-settings)
(mutex initform: (make-mutex 'game) accessor: game-mutex)))
@@ -169,8 +170,8 @@
(mutex initform: (make-mutex 'app) accessor: app-mutex)))
(define (player->sexp player)
`((cash . ,(player-cash player))
(debt . ,(player-debt player))
`((cash . ,(inexact->exact (round (player-cash player))))
(debt . ,(inexact->exact (round (player-debt player))))
(space . ,(player-space player))
(previous-space . ,(player-previous-space player))
(state . ,(player-state player))
@@ -247,12 +248,54 @@
'games (map sexp->game (alist-ref 'games x))
'last-game-id (alist-ref 'last-game-id x)))
(define (save-app)
(with-output-to-file "/home/tjhintz/app.scm"
(lambda ()
(write (app->sexp *app*)))))
(define (validate-game g)
(assert (instance-of? g <game>))
(assert (number? (game-id g)))
(assert (list? (game-players g)))
(for-each (lambda (p)
(assert (instance-of? p <player>))
(assert (number? (player-cash p)))
(assert (number? (player-display-cash p)))
(assert (= (player-cash p) (player-display-cash p)))
(assert (number? (player-debt p)))
(assert (number? (player-space p)))
(assert (number? (player-previous-space p)))
(assert (symbol? (player-state p)))
(assert (member (player-state p) '(turn-ended pre-turn mid-turn)))
(assert (boolean? (player-finished p)))
(assert (list? (player-assets p))) ;; TODO test assets
(assert (list? (player-ridges p)))
(assert (number? (player-harvest-mult p)))
(assert (list? (player-otbs p)))
(assert (list? (player-farmers-fates p)))
(assert (list? (player-year-rules p)))
(assert (list? (player-next-year-rules p)))
(assert (symbol? (player-color p)))
(assert (string? (player-name p)))
(assert (number? (player-user-id p)))
(assert (list? (player-trade p)))
(assert (number? (player-last-cash p)))
(assert (boolean? (player-harvesting p)))
(assert (boolean? (player-hay-doubled p)))
(assert (boolean? (player-corn-doubled p))))
(game-players g))
(assert (list? (game-otbs g)))
(assert (list? (game-used-otbs g)))
(assert (list? (game-farmers-fates g)))
(assert (list? (game-operating-expenses g)))
(assert (number? (game-operating-expense-index g)))
(assert (list? (game-colors g)))
(assert (or (instance-of? (game-called-audit g) <player>)
(boolean? (game-called-audit g))))
(assert (symbol? (game-state g))) ;; TODO test all symbols
(assert (string? (game-name g)))
(assert (number? (game-turn g)))
(assert (or (instance-of? (game-current-player g) <player>)
(boolean? (game-current-player g))))
(assert (list? (game-settings g))))
(define (save-game game)
(validate-game game)
(db-update-game (game-id game) (symbol->string (game-state game))
(game->sexp game)))
@@ -293,7 +336,9 @@
(set-cookie! (session-cookie-name) sid))))
(session-lifetime (* 60 60 24 7 4))
(access-log (current-output-port))
;; (access-log (current-output-port))
(access-log "access.log")
(error-log "error.log")
(handle-not-found
(let ((old-handler (handle-not-found)))
@@ -577,14 +622,21 @@
(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)))
;; (bonus (max (farming-round
;; (inexact->exact
;; (round
;; (* (- (player-net-worth richest)
;; (+ (player-net-worth player)
;; ;; don't give a bonus for emergency debt
;; (max 0 (- (player-debt player) (game-setting 'max-debt game)))))
;; 0.2))))
;; 2500))
(bonus 5000)
)
(safe-set! (player-cash player)
;; (+ (player-cash player) 5000)
(+ (player-cash player) bonus))
(+ (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)
@@ -827,8 +879,8 @@
#f)))
(define (call-audit game player)
(if (game-called-audit game)
(begin (safe-set! (game-called-audit game) player))))
(if (not (game-called-audit game))
(safe-set! (game-called-audit game) player)))
(define (player-net-worth player)
(+ (* (+ (player-asset 'hay player) (player-asset 'grain player)) 2000)
@@ -942,6 +994,17 @@
rolls))
(_make-rolls n 1 (list (next-roll -1))))
(define (log-error exn)
(with-output-to-file (error-log)
(lambda ()
(print-call-chain)
(print exn)
(print-error-message exn))
append:))
(define (log-msg msg)
(log-to (error-log) "~A" msg))
(define (process-message player game type msg)
(when player
(safe-set! (player-last-cash player) (player-cash player)))
@@ -1253,10 +1316,8 @@
(begin (advance-turn game player)
(handle-exceptions
exn
(begin (print-call-chain)
(print exn)
(print-error-message exn)
(print "error saving app"))
(begin (log-error exn)
(log-msg "error saving app"))
(save-game game))
(if (eq? (game-state game) 'finished)
(do-end-of-game game)
@@ -1286,6 +1347,10 @@
0))
(starting-debt . ,(->i (alist-ref 'startingDebt msg)
0))
(starting-otbs . ,(min (max (->number (alist-ref 'startingOtbs msg)
2)
0)
8))
(trade . ,(or (alist-ref 'trade msg) #t)))))
(player (add-player-to-game game
color
@@ -1301,7 +1366,7 @@
(session-set! (sid) 'game-id (game-id game)))
(*game* game)
(*player* player)
(set-startup-otbs game player 2)
(set-startup-otbs game player (alist-ref 'starting-otbs (game-settings game)))
;; (set-startup-otbs game ai-player 2)
;; (thread-start! (make-ai-push-receiver game ai-player))
(create-start-response "new-game-started")))
@@ -1323,11 +1388,12 @@
(db-add-user-game (alist-ref 'id user) (game-id game))
(*game* game)
(*player* player)
(set-startup-otbs game player 2)
(set-startup-otbs game player (alist-ref 'starting-otbs (game-settings game)))
(message-players! game player '() type: "update")
(create-start-response "new-game-started")))
((string=? type "join-as-existing")
(let* ((id (alist-ref 'gameId msg))
(let* ((id (or (alist-ref 'gameId msg)
(session-ref (sid) 'game-id)))
(user-id (session-ref (sid) 'user-id))
(game (find-game id))
(player (find (lambda (p) (equal? (player-user-id p) user-id))
@@ -1440,19 +1506,19 @@
exn
(send-message
(json->string
`((exn . ,(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn))))
`((exn . ,(begin (log-error exn)
(conc "Server error: " (with-output-to-string
(lambda ()
(print-error-message exn))))))
(event . "error"))))
(send-message
(json->string
(handle-exceptions
exn
`((exn . ,(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn))))
`((exn . ,(begin (log-error exn)
(conc "Server error: " (with-output-to-string
(lambda ()
(print-error-message exn))))))
(event . "error"))
(session-game)
(let* ((game (*game*))
@@ -1492,18 +1558,18 @@
exn
(send-message
(json->string
`((exn . ,(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn)))))))
`((exn . ,(begin (log-error exn)
(conc "Server error: " (with-output-to-string
(lambda ()
(print-error-message exn)))))))))
(send-message
(json->string
(handle-exceptions
exn
`((exn . ,(with-output-to-string
(lambda ()
(print-call-chain)
(print-error-message exn))))
`((exn . ,(begin (log-error exn)
(conc "Server error: " (with-output-to-string
(lambda ()
(print-error-message exn))))))
(event . "error"))
(create-ws-response (*player*)
(alist-ref 'type msg)
@@ -2143,7 +2209,10 @@
(let ((value (alist-ref '?value action)))
(if (procedure? value)
(value player)
(apply (alist-ref (car value) *action-map*) player (cdr value)))))
(let ((action-proc (alist-ref (car value) *action-map*)))
(if (procedure? action-proc)
(apply action-proc player (cdr value))
(print (conc "unknown action value: " value)))))))
((eq? a 'harvest-mult)
(safe-set! (player-harvest-mult player)
(* (player-harvest-mult player) (alist-ref '?value action))))
@@ -2314,3 +2383,207 @@
;; Error: (assv) bad argument type: #<coops instance of `<game>'>
;; when getting trade the name is wrong
;; error:
;; Call history:
;; farm.scm:482: player-last-cash
;; farm.scm:99: coops#slot-value
;; farm.scm:483: player-hay-doubled
;; farm.scm:99: coops#slot-value
;; farm.scm:484: player-corn-doubled
;; farm.scm:99: coops#slot-value
;; farm.scm:513: list->vector
;; farm.scm:517: game-called-audit
;; farm.scm:135: coops#slot-value
;; farm.scm:518: game-called-audit
;; farm.scm:135: coops#slot-value
;; farm.scm:518: player-name
;; farm.scm:1450: k8469
;; farm.scm:1450: g8473
;; farm.scm:1452: with-output-to-string
;; farm.scm:1454: print-call-chain <--
;; Error: (player-name) no method defined for given argument classes: (#t)
;; clicking roll button
;; start game with more otbs
;; Error: (assv) bad argument type: #f
;; Call history:
;; numbers.scm:1672: scan-real
;; numbers.scm:1671: scan-ureal
;; numbers.scm:1603: scan-digits+hashes
;; numbers.scm:1549: scan-digits
;; numbers.scm:1531: lp
;; numbers.scm:1531: lp
;; numbers.scm:1548: g1937
;; numbers.scm:1720: %string->compnum
;; numbers.scm:1672: scan-real
;; numbers.scm:1671: scan-ureal
;; numbers.scm:1603: scan-digits+hashes
;; numbers.scm:1549: scan-digits
;; numbers.scm:1531: lp
;; numbers.scm:1548: g1937
;; farm.scm:50: expiration
;; farm.scm:43: current-milliseconds
;; farm.scm:44: http-session#session-lifetime
;; farm.scm:44: numbers#*
;; numbers.scm:382: %*
;; farm.scm:44: numbers#floor
;; farm.scm:44: numbers#inexact->exact
;; numbers.scm:867: exact?
;; farm.scm:43: numbers#+
;; numbers.scm:295: %+
;; farm.scm:50: spiffy#remote-address
;; farm.scm:50: http-session#make-session-item
;; farm.scm:1441: *game*
;; farm.scm:1449: *game*
;; farm.scm:1476: *game*
;; farm.scm:1477: *player*
;; farm.scm:1479: alist-ref
;; farm.scm:1468: k8474
;; farm.scm:1468: g8478
;; farm.scm:1470: log-error
;; farm.scm:954: spiffy#error-log
;; farm.scm:954: with-output-to-file
;; farm.scm:956: print-call-chain
;; farm.scm:957: print
;; farm.scm:958: print-error-message
;; farm.scm:1471: with-output-to-string
;; farm.scm:1473: print-error-message
;; farm.scm:1471: conc
;; farm.scm:1467: medea#json->string
;; farm.scm:1466: websockets#send-message
;; farm.scm:1455: k8462
;; farm.scm:1455: g8466
;; farm.scm:1461: log-error
;; farm.scm:954: spiffy#error-log
;; farm.scm:954: with-output-to-file
;; farm.scm:956: print-call-chain <--
;; #<condition: (exn i/o net)>
;; Error: cannot write to socket - Broken pipe: 7
;; [Sat Apr 11 23:04:48 2020] "GET http://localhost:8080/websocket/web-socket HTTP/1.1" Uncaught exception:
;; #<condition: (uncaught-exception)>
;; Call history:
;; farm.scm:164: game-settings
;; farm.scm:135: coops#slot-value
;; farm.scm:164: alist-ref
;; farm.scm:164: game-settings
;; farm.scm:135: coops#slot-value
;; farm.scm:164: alist-ref
;; farm.scm:164: game-settings
;; farm.scm:135: coops#slot-value
;; farm.scm:164: alist-ref
;; farm.scm:164: game-settings
;; farm.scm:135: coops#slot-value
;; farm.scm:164: alist-ref
;; farm.scm:164: game-settings
;; farm.scm:135: coops#slot-value
;; farm.scm:164: alist-ref
;; farm.scm:866: append
;; farm.scm:1483: game-last-updated
;; farm.scm:135: coops#slot-value
;; farm.scm:1483: numbers#+
;; numbers.scm:295: %+
;; farm.scm:1483: game-mutex
;; farm.scm:135: coops#slot-value
;; farm.scm:1483: dynamic-wind
;; farm.scm:1483: mutex-lock!
;; farm.scm:1483: ##sys#setter
;; farm.scm:1483: g8506
;; farm.scm:135: coops#set-slot-value!
;; farm.scm:1483: mutex-unlock!
;; farm.scm:1484: *player*
;; farm.scm:1485: *player*
;; farm.scm:1485: game-last-updated
;; farm.scm:135: coops#slot-value
;; farm.scm:1485: player-mutex
;; farm.scm:99: coops#slot-value
;; farm.scm:1485: dynamic-wind
;; farm.scm:1485: mutex-lock!
;; farm.scm:1485: ##sys#setter
;; farm.scm:1485: g8526
;; farm.scm:99: coops#set-slot-value!
;; farm.scm:1485: mutex-unlock!
;; tmp213217
;; farm.scm:1469: k8475
;; farm.scm:1469: g8479
;; farm.scm:1468: medea#json->string
;; farm.scm:1456: k8463
;; farm.scm:1456: g8467
;; farm.scm:1462: log-error
;; farm.scm:955: spiffy#error-log
;; farm.scm:955: with-output-to-file
;; farm.scm:957: print-call-chain <--
;; #<condition: (exn type)>
;; Error: (symbol->string) bad argument type - not a symbol: (contents . "\n<p>LEASE Marineris Ridge</p>\n<p>for 30 years at $20,000</p>\n<p>...
;; rror: (assv) bad argument type: pre-turn
;; Call history:
;; sql-de-lite.scm:600: statement-ptr
;; sql-de-lite.scm:609: statement-ptr
;; sql-de-lite.scm:222: ##sys#block-set!
;; sql-de-lite.scm:612: remove-active-statement!
;; sql-de-lite.scm:202: hash-table-delete!
;; sql-de-lite.scm:893: for-each-active-statement
;; sql-de-lite.scm:204: hash-table-walk
;; sql-de-lite.scm:172: ##sys#block-set!
;; sql-de-lite.scm:897: object-release
;; sql-de-lite.scm:172: ##sys#block-set!
;; db.scm:28: alist-ref
;; db.scm:27: with-input-from-string
;; numbers.scm:1720: %string->compnum
;; numbers.scm:1672: scan-real
;; numbers.scm:1671: scan-ureal
;; numbers.scm:1603: scan-digits+hashes
;; numbers.scm:1549: scan-digits
;; numbers.scm:1531: lp
;; numbers.scm:1531: lp
;; numbers.scm:1548: g1937
;; numbers.scm:1720: %string->compnum
;; numbers.scm:1672: scan-real
;; numbers.scm:1671: scan-ureal
;; numbers.scm:1603: scan-digits+hashes
;; numbers.scm:1549: scan-digits
;; numbers.scm:1531: lp
;; numbers.scm:1548: g1937
;; farm.scm:50: expiration
;; farm.scm:43: current-milliseconds
;; farm.scm:44: http-session#session-lifetime
;; farm.scm:44: numbers#*
;; numbers.scm:382: %*
;; farm.scm:44: numbers#floor
;; farm.scm:44: numbers#inexact->exact
;; numbers.scm:867: exact?
;; farm.scm:43: numbers#+
;; numbers.scm:295: %+
;; farm.scm:50: spiffy#remote-address
;; farm.scm:50: http-session#make-session-item
;; farm.scm:1484: *game*
;; farm.scm:1492: *game*
;; farm.scm:1519: *game*
;; farm.scm:1520: *player*
;; farm.scm:1522: alist-ref
;; farm.scm:1511: k8652
;; farm.scm:1511: g8656
;; farm.scm:1513: log-error
;; farm.scm:997: spiffy#error-log
;; farm.scm:997: with-output-to-file
;; farm.scm:999: print-call-chain <--
;; #<condition: (exn type)>