turtle-r7rs/server/start-kawa-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")

(include "./web-server.scm")

(define default-port 43334)

(define (main args)
  (define current-port
    (if (null? (cdr args))
        default-port
        (string->number (cadr args))))
  
  (define server ::HttpServer (HttpServer:create (InetSocketAddress current-port) 0))
  (server:createContext "/api/NewId" (NewIdHandler))
  (server:createContext "/api/PushBuffer" (PushBufferHandler))
  (server:createContext "/api/PushBulkBuffer" (PushBulkBufferHandler))
  (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))

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

(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 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 1000))
                                                                                not-found))))

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

(define PullBufferHandler (make-handler "application/json; charset=UTF-8" (lambda (method headers body)
                                                                            (if (string=? method "POST")
                                                                                (json-write-string (api-pull-buffer! (filter-input-stream->string body 1000)))
                                                                                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) (sxml->xml index-page))))

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

(main (command-line))