121 lines
3.5 KiB
Scheme
121 lines
3.5 KiB
Scheme
(import (scheme base)
|
|
(chicken port)
|
|
(chicken irregex)
|
|
(chicken time posix)
|
|
srfi-123
|
|
srfi-69
|
|
srfi-48
|
|
srfi-18
|
|
intarweb
|
|
spiffy
|
|
awful
|
|
(awful sse)
|
|
sxml-transforms)
|
|
|
|
;; Game
|
|
(define games (make-hash-table))
|
|
|
|
(define (init-game-table)
|
|
(let ((game (make-hash-table)))
|
|
game))
|
|
|
|
;; Webserver stuff
|
|
(define (add-sse-resource! sse-path sse-proc vhost-root-path client-path)
|
|
(add-resource! sse-path
|
|
(or vhost-root-path (root-path))
|
|
(lambda (#!optional given-path)
|
|
(let ((accept (header-values 'accept
|
|
(request-headers (current-request)))))
|
|
;; If client's EventSource (JS code) requested SSE page...
|
|
(if (memq 'text/event-stream accept)
|
|
;;...complete handshake & keep connection alive with 'sse-proc'.
|
|
(lambda ()
|
|
(with-headers '((content-type text/event-stream)
|
|
(cache-control no-cache)
|
|
(connection keep-alive))
|
|
(lambda ()
|
|
(write-logged-response)
|
|
(sse-proc))))
|
|
(redirect-to client-path))))
|
|
'GET
|
|
#f))
|
|
|
|
(define (pagescript sse-path color)
|
|
#<#EOF
|
|
eventsource ssevent from #{sse-path}
|
|
|
|
on unlockMessage as string
|
|
if it is "#{color}"
|
|
set #board.data-locked to 'false'
|
|
end
|
|
end
|
|
|
|
end
|
|
EOF
|
|
)
|
|
|
|
(define (render-sxml sxml)
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(SXML->HTML sxml))))
|
|
|
|
(define (board sse-path color)
|
|
(let ()
|
|
`(div (@ (id "content")
|
|
(class "row"))
|
|
(div (@ (id "leftbank")
|
|
(class "col-2 m-0")))
|
|
(div (@ (id "board")
|
|
(data-locked ,(if (eqv? color "white") "true" "false"))
|
|
(class "col-8 m-0 p-0")))
|
|
(div (@ (id "rightbank")
|
|
(class "col-2 m-0"))))))
|
|
|
|
(define (game-proc code)
|
|
(print "Returning sse-proc")
|
|
(lambda ()
|
|
(let loop ()
|
|
(send-sse-data (render-positions)
|
|
id: (seconds->string) event: "boardChange")
|
|
(thread-sleep! 2)
|
|
(loop))))
|
|
|
|
(define (init-game code)
|
|
(let ((game (or (and (hash-table-exists? games code)
|
|
(~ games code))
|
|
#f))
|
|
(sse-path (string-append "/sse-" code))
|
|
(sse-proc (game-proc code)))
|
|
(print "Game:" game)
|
|
(if game
|
|
(board sse-path "white")
|
|
(let ((game (init-game-table)))
|
|
(print "Initialized game to " game ", adding SSE resource.")
|
|
(set! (~ game 'sse-proc) (add-sse-resource! sse-path sse-proc #f sse-path))
|
|
(set! (~ game 'code) code)
|
|
(set! (~ games code) game)
|
|
(board sse-path "yellow")))))
|
|
|
|
(define-page "/start-game"
|
|
(lambda ()
|
|
(let ((gamecode ($ 'gamecode as-string)))
|
|
(init-game gamecode))))
|
|
|
|
(define-page "/"
|
|
(lambda ()
|
|
(lambda ()
|
|
(send-static-file "resources/html/coinage.html")))
|
|
no-template: #t)
|
|
|
|
(define-page "/css/coinage.css"
|
|
(lambda ()
|
|
(lambda ()
|
|
(send-static-file "resources/css/coinage.css"))))
|
|
|
|
(define-page (irregex "/images/.*")
|
|
(lambda (file)
|
|
(print "Trying to fetch file " file "...")
|
|
(lambda ()
|
|
(print "Fetching " file "...")
|
|
(send-static-file (string-append "resources" file)))))
|