@ -18,7 +18,7 @@
;;; <https://www.gnu.org/licenses/>. ;;; <https://www.gnu.org/licenses/>.
( import chicken scheme srfi-1 data-structures ) ( import chicken scheme srfi-1 data-structures )
( use http-session srfi-69 coops ( use http-session srfi-69 coops coops-utils uri-common
srfi-18 medea numbers spiffy spiffy-cookies
srfi-18 medea numbers spiffy spiffy-cookies
intarweb pll sxml-transforms websockets miscmacros
intarweb pll sxml-transforms websockets miscmacros
mailbox )
mailbox )
@ -156,7 +156,8 @@
( audit-threshold . 250000 )
( audit-threshold . 250000 )
( starting-cash . 5000 )
( starting-cash . 5000 )
( starting-debt . 5000 )
( starting-debt . 5000 )
( trade . #t ) )
( trade . #t )
( starting-otbs . 2 ) )
accessor: game-settings )
accessor: game-settings )
( mutex initform: ( make-mutex 'game ) accessor: game-mutex ) ) )
( mutex initform: ( make-mutex 'game ) accessor: game-mutex ) ) )
@ -169,8 +170,8 @@
( mutex initform: ( make-mutex 'app ) accessor: app-mutex ) ) )
( mutex initform: ( make-mutex 'app ) accessor: app-mutex ) ) )
( define ( player->sexp player ) ( define ( player->sexp player )
` ( ( cash . , ( player-cash player ) )
` ( ( cash . , ( inexact->exact ( round ( player-cash player ) ) ) )
( debt . , ( player-debt player ) )
( debt . , ( inexact->exact ( round ( player-debt player ) ) ) )
( space . , ( player-space player ) )
( space . , ( player-space player ) )
( previous-space . , ( player-previous-space player ) )
( previous-space . , ( player-previous-space player ) )
( state . , ( player-state player ) )
( state . , ( player-state player ) )
@ -247,12 +248,54 @@
'games ( map sexp->game ( alist-ref 'games x ) )
'games ( map sexp->game ( alist-ref 'games x ) )
'last-game-id ( alist-ref 'last-game-id x ) ) )
'last-game-id ( alist-ref 'last-game-id x ) ) )
( define ( save-app ) ( define ( validate-game g )
( with-output-to-file "/home/tjhintz/app.scm"
( assert ( instance-of? g <game> ) )
( lambda ( )
( assert ( number? ( game-id g ) ) )
( write ( app->sexp *app* ) ) ) ) )
( 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 ) ( define ( save-game game )
( validate-game game )
( db-update-game ( game-id game ) ( symbol->string ( game-state game ) )
( db-update-game ( game-id game ) ( symbol->string ( game-state game ) )
( game->sexp game ) ) )
( game->sexp game ) ) )
@ -293,7 +336,9 @@
( set-cookie! ( session-cookie-name ) sid ) ) ) )
( set-cookie! ( session-cookie-name ) sid ) ) ) )
( session-lifetime ( * 60 60 24 7 4 ) ) ( 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 ( handle-not-found
( let ( ( old-handler ( handle-not-found ) ) )
( let ( ( old-handler ( handle-not-found ) ) )
@ -577,14 +622,21 @@
( lambda ( p1 p2 )
( lambda ( p1 p2 )
( > ( player-net-worth p1 )
( > ( player-net-worth p1 )
( player-net-worth p2 ) ) ) ) ) )
( player-net-worth p2 ) ) ) ) ) )
( bonus ( max ( farming-round
;; (bonus (max (farming-round
( * ( - ( player-net-worth richest )
;; (inexact->exact
( player-net-worth player ) )
;; (round
0.2 ) )
;; (* (- (player-net-worth richest)
2500 ) ) )
;; (+ (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 )
( safe-set! ( player-cash player )
;; (+ (player-cash player) 5000)
( + ( player-cash player ) 5000 )
( + ( player-cash player ) bonus ) )
;; (+ (player-cash player) bonus)
)
( safe-set! ( player-display-cash player ) ( player-cash player ) )
( safe-set! ( player-display-cash player ) ( player-cash player ) )
( safe-set! ( game-actions game )
( safe-set! ( game-actions game )
( cons ` ( ( ?action . info )
( cons ` ( ( ?action . info )
@ -827,8 +879,8 @@
#f ) ) )
#f ) ) )
( define ( call-audit game player ) ( define ( call-audit game player )
( if ( game-called-audit game )
( if ( not ( game-called-audit game ) )
( begin ( safe-set! ( game-called-audit game ) player ) ) ) )
( safe-set! ( game-called-audit game ) player ) ) )
( define ( player-net-worth player ) ( define ( player-net-worth player )
( + ( * ( + ( player-asset 'hay player ) ( player-asset 'grain player ) ) 2000 )
( + ( * ( + ( player-asset 'hay player ) ( player-asset 'grain player ) ) 2000 )
@ -942,6 +994,17 @@
rolls ) )
rolls ) )
( _make-rolls n 1 ( list ( next-roll -1 ) ) ) )
( _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 ) ( define ( process-message player game type msg )
( when player
( when player
( safe-set! ( player-last-cash player ) ( player-cash player ) ) )
( safe-set! ( player-last-cash player ) ( player-cash player ) ) )
@ -1253,10 +1316,8 @@
( begin ( advance-turn game player )
( begin ( advance-turn game player )
( handle-exceptions
( handle-exceptions
exn
exn
( begin ( print-call-chain )
( begin ( log-error exn )
( print exn )
( log-msg "error saving app" ) )
( print-error-message exn )
( print "error saving app" ) )
( save-game game ) )
( save-game game ) )
( if ( eq? ( game-state game ) 'finished )
( if ( eq? ( game-state game ) 'finished )
( do-end-of-game game )
( do-end-of-game game )
@ -1286,6 +1347,10 @@
0 ) )
0 ) )
( starting-debt . , ( ->i ( alist-ref 'startingDebt msg )
( starting-debt . , ( ->i ( alist-ref 'startingDebt msg )
0 ) )
0 ) )
( starting-otbs . , ( min ( max ( ->number ( alist-ref 'startingOtbs msg )
2 )
0 )
8 ) )
( trade . , ( or ( alist-ref 'trade msg ) #t ) ) ) ) )
( trade . , ( or ( alist-ref 'trade msg ) #t ) ) ) ) )
( player ( add-player-to-game game
( player ( add-player-to-game game
color
color
@ -1301,7 +1366,7 @@
( session-set! ( sid ) 'game-id ( game-id game ) ) )
( session-set! ( sid ) 'game-id ( game-id game ) ) )
( *game* game )
( *game* game )
( *player* player )
( *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)
;; (set-startup-otbs game ai-player 2)
;; (thread-start! (make-ai-push-receiver game ai-player))
;; (thread-start! (make-ai-push-receiver game ai-player))
( create-start-response "new-game-started" ) ) )
( create-start-response "new-game-started" ) ) )
@ -1323,11 +1388,12 @@
( db-add-user-game ( alist-ref 'id user ) ( game-id game ) )
( db-add-user-game ( alist-ref 'id user ) ( game-id game ) )
( *game* game )
( *game* game )
( *player* player )
( *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" )
( message-players! game player ' ( ) type: "update" )
( create-start-response "new-game-started" ) ) )
( create-start-response "new-game-started" ) ) )
( ( string=? type "join-as-existing" )
( ( 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 ) )
( user-id ( session-ref ( sid ) 'user-id ) )
( game ( find-game id ) )
( game ( find-game id ) )
( player ( find ( lambda ( p ) ( equal? ( player-user-id p ) user-id ) )
( player ( find ( lambda ( p ) ( equal? ( player-user-id p ) user-id ) )
@ -1440,19 +1506,19 @@
exn
exn
( send-message
( send-message
( json->string
( json->string
` ( ( exn . , ( with-output-to-string
` ( ( exn . , ( begin ( log-error exn )
( conc "Server error: " ( with-output-to-string
( lambda ( )
( lambda ( )
( print-call-chain )
( print-error-message exn ) ) ) ) ) )
( print-error-message exn ) ) ) )
( event . "error" ) ) ) )
( event . "error" ) ) ) )
( send-message
( send-message
( json->string
( json->string
( handle-exceptions
( handle-exceptions
exn
exn
` ( ( exn . , ( with-output-to-string
` ( ( exn . , ( begin ( log-error exn )
( conc "Server error: " ( with-output-to-string
( lambda ( )
( lambda ( )
( print-call-chain )
( print-error-message exn ) ) ) ) ) )
( print-error-message exn ) ) ) )
( event . "error" ) )
( event . "error" ) )
( session-game )
( session-game )
( let* ( ( game ( *game* ) )
( let* ( ( game ( *game* ) )
@ -1492,18 +1558,18 @@
exn
exn
( send-message
( send-message
( json->string
( json->string
` ( ( exn . , ( with-output-to-string
` ( ( exn . , ( begin ( log-error exn )
( conc "Server error: " ( with-output-to-string
( lambda ( )
( lambda ( )
( print-call-chain )
( print-error-message exn ) ) ) ) ) ) ) ) )
( print-error-message exn ) ) ) ) ) ) )
( send-message
( send-message
( json->string
( json->string
( handle-exceptions
( handle-exceptions
exn
exn
` ( ( exn . , ( with-output-to-string
` ( ( exn . , ( begin ( log-error exn )
( conc "Server error: " ( with-output-to-string
( lambda ( )
( lambda ( )
( print-call-chain )
( print-error-message exn ) ) ) ) ) )
( print-error-message exn ) ) ) )
( event . "error" ) )
( event . "error" ) )
( create-ws-response ( *player* )
( create-ws-response ( *player* )
( alist-ref 'type msg )
( alist-ref 'type msg )
@ -2143,7 +2209,10 @@
( let ( ( value ( alist-ref '?value action ) ) )
( let ( ( value ( alist-ref '?value action ) ) )
( if ( procedure? value )
( if ( procedure? value )
( value player )
( 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 )
( ( eq? a 'harvest-mult )
( safe-set! ( player-harvest-mult player )
( safe-set! ( player-harvest-mult player )
( * ( player-harvest-mult player ) ( alist-ref '?value action ) ) ) )
( * ( player-harvest-mult player ) ( alist-ref '?value action ) ) ) )
@ -2314,3 +2383,207 @@
;; Error: (assv) bad argument type: #<coops instance of `<game>'> ;; Error: (assv) bad argument type: #<coops instance of `<game>'>
;; when getting trade the name is wrong ;; 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)>
