server/gauche-tk.client.scm

@@ -4,7 +4,10 @@
   (scheme read)
   (scheme write)
   (scheme inexact)
+  (scheme process-context)
+  (only (gauche base) exit-handler)
   (gauche threads)
+  (srfi 18)
   (srfi 180)
   (rfc http)
   (tk))
@@ -181,11 +184,14 @@
 
 (define (get-session-id!)
   (define session-source-path "/api/NewId")
-  (define-values (status-code response-header new-id-json) (http-get json-source-server session-source-path))
+  (define-values (status-code response-header new-id-json) (http-post json-source-server session-source-path "null"))
+
+(write new-id-json)(newline)
+
   (let ((p (open-input-string new-id-json)))
     (define new-id (json-read p))
     (close-input-port p)
-    (set! page-id (string->number new-id))))
+    (set! page-id new-id)))
 
 (define (on-interval!)
   (define-values (status-code response-header turtle-json) (http-post json-source-server json-source-path (number->string page-id)))
@@ -202,8 +208,16 @@
 (set-bg-color! (json-object->turtle-action '((color . "black"))))
 (set-line-color! (json-object->turtle-action '((color . "white"))))
 (set-line-width! (json-object->turtle-action '((width . 1.0))))
+(exit-handler (lambda (code fmtstr args) (tk-shutdown)))
+(tk-bind "." '<Destroy> (tklambda () (exit)))
 
-(let loop ()
+(define (background-loop)
   (on-interval!)
   (thread-sleep! 0.5)
-  (loop))
+  (background-loop))
+
+(define t (make-thread background-loop))
+
+(thread-start! t)
+
+(tk-mainloop)

server/start-gauche-server.scm

@@ -38,33 +38,31 @@
     (respond/ok req '(file "canvas.js"))))
 
 ;; new id handler
-(define-http-handler "/api/NewId"
+(define-http-handler (POST) "/api/NewId"
   (lambda (req app)
-    (respond/ok req (list 'json (api-new-id!)))))
+    (respond/ok req (list 'json (string->number (api-new-id!))))))
 
 ;; push buffer handler
-(define-http-handler "/api/PushBuffer"
+(define-http-handler (POST) "/api/PushBuffer"
   (lambda (req app)
     (let ((body (utf8->string (read-request-body req))))
       (respond/ok req (list 'json (api-push-buffer! body))))))
 
 ;; push bulk buffer handler
-(define-http-handler "/api/PushBulkBuffer"
+(define-http-handler (POST) "/api/PushBulkBuffer"
   (lambda (req app)
     (let ((body (utf8->string (read-request-body req))))
       (respond/ok req (list 'json (api-push-bulk-buffer! body))))))
 
 ;; pull buffer handler
-(define-http-handler "/api/PullBuffer"
+(define-http-handler (POST) "/api/PullBuffer"
   (lambda (req app)
     (let ((body (utf8->string (read-request-body req))))
       (respond/ok req (list 'json (api-pull-buffer! body))))))
 
 ;; clear buffer handler
-(define-http-handler "/api/ClearBuffer"
+(define-http-handler (POST) "/api/ClearBuffer"
   (lambda (req app)
     (api-clear-buffer!)))
 
 (main (command-line))
-
-