turtle-r7rs/server/server.scm

(import
  (class java.io IOException OutputStream FilterInputStream)
  (class java.net InetSocketAddress)
  (class com.sun.net.httpserver HttpExchange HttpHandler HttpServer)
  (macduffie sxml)
  (macduffie json))

(include "./canvas.js")

(define complete-history '())

(define buffer-list '())

(define index-page ::String
  (sxml->xml
   `(html
     (head
      (title "Turtle Canvas"))
     (body
      (div
       (|@| (style "position: relative;"))
       (canvas
        (|@| (id "BgCanvas")
             (width "1000")
             (height "1000")
             (style "position: absolute; left: 0; top: 0; z-index: 0;")))
       (canvas
        (|@| (id "LineCanvas")
             (width "1000")
             (height "1000")
             (style "position: absolute; left: 0; top: 0; z-index: 1;")))
       (canvas
        (|@| (id "TurtleCanvas")
             (width "1000")
             (height "1000")
             (style "position: absolute; left: 0; top: 0; z-index: 2;"))))
      (script
       (|@| (src "https://ajax.googleapis.com/ajax/libs/jquery/3.1.0/jquery.min.js")))
      (script
       (|@| (src "/draw.js")))))))

(define not-found ::String "404NOTFOUND")

(define (make-handler content-type ::String body-proc)
  (define-class result (HttpHandler)
    ((handle (t ::HttpExchange))
     ((t:getResponseHeaders):set "Content-Type" content-type)
     (let ()
       (define os ::OutputStream #!null)
       (define request-method (t:getRequestMethod))
       (define request-headers (t:getRequestHeaders))
       (define request-body (t:getRequestBody))
       (define body ::String (body-proc request-method request-headers request-body))
       (define response ::byte[] (body:getBytes))
       (cond
        ((string=? body not-found)
         (set! body "")
         (set! response (body:getBytes))
         (t:sendResponseHeaders 404 0))
        (else
         (t:sendResponseHeaders 200 response:length)))
       (set! os (t:getResponseBody))
       (os:write response)
       (os:close))))

  result)

(define (api-new-id!)
  (set! buffer-list (append buffer-list (list complete-history)))
  (number->string (length buffer-list)))

(define (api-push-buffer! s)
  (let ((p (open-input-string s)))
    (let ((input-result (read p)))
      (close-input-port p)
      (set! complete-history (cons input-result complete-history))
      (set! buffer-list (map (lambda (buff) (cons input-result buff)) buffer-list))
      "true\n")))

(define (api-pull-buffer! s)
  (define n -1)
  (let ((p (open-input-string s)))
    (let ((input-result (read p)))
      (close-input-port p)
      (when (integer? input-result) (set! n input-result))
      (let ((result (list-ref buffer-list (- (length buffer-list) n))))
        (list-set! buffer-list (- (length buffer-list) n) '())
        (json-write-string (list->vector (reverse result)))))))

(define (api-clear-buffer!)
  (set! complete-history '())
  (set! buffer-list (make-list (length buffer-list) '())))

(define (filter-input-stream->string fis ::FilterInputStream)
  (define b ::byte[] (byte[] length: 1000))
  (fis:read b)
  (String b))

(define NewIdHandler (make-handler "application/json; charset=UTF-8" (lambda (method headers body)
                                                                       (if (string=? method "POST")
                                                                           (api-new-id!)
                                                                           not-found))))

(define PushBufferHandler (make-handler "application/json; charset=UTF-8" (lambda (method headers body)
                                                                            (if (string=? method "POST")
                                                                                (api-push-buffer! (filter-input-stream->string body))
                                                                                not-found))))

(define PullBufferHandler (make-handler "application/json; charset=UTF-8" (lambda (method headers body)
                                                                            (if (string=? method "POST")
                                                                                (api-pull-buffer! (filter-input-stream->string body))
                                                                                not-found))))

(define ClearBufferHandler (make-handler "application/json; charset=UTF-8" (lambda (method headers body)
                                                                             (if (string=? method "POST")
                                                                                 (api-clear-buffer!)
                                                                                 not-found))))

(define FrontendHandler (make-handler "text/html; charset=UTF-8" (lambda (method headers body) index-page)))

(define ScriptingHandler (make-handler "application/javascript; charset=UTF-8" (lambda (method headers body) script-page)))

(define server ::HttpServer (HttpServer:create (InetSocketAddress 43334) 0))
(server:createContext "/api/NewId" (NewIdHandler))
(server:createContext "/api/PushBuffer" (PushBufferHandler))
(server:createContext "/api/PullBuffer" (PullBufferHandler))
(server:createContext "/api/ClearBuffer" (ClearBufferHandler))
(server:createContext "/index.html" (FrontendHandler))
(server:createContext "/" (FrontendHandler))
(server:createContext "/draw.js" (ScriptingHandler))
(server:setExecutor #!null)
(server:start)