-

webui-ffi.rkt

@@ -3,11 +3,14 @@
 (require ffi/unsafe
          ffi/unsafe/define
          ffi/unsafe/atomic
+         racket/async-channel
          racket/runtime-path
          racket/port
          data/queue
          json
          racket/string
+         racket/path
+         "mimetypes.rkt"
          )
 
 (provide webui-new-window
@@ -20,7 +23,7 @@
 ;; FFI Library
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define lib-type 'debug)
+(define lib-type 'release)
 
 (define-runtime-path lib-dir "lib")
 
@@ -54,19 +57,6 @@
 ;; Handling events
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define event-queue (make-queue))
-(define webui-event-queue (make-queue))
-
-;typedef struct webui_event_t {
-;    size_t window;          // The window object number
-;    size_t event_type;      // Event type
-;    char* element;          // HTML element ID
-;    size_t event_number;    // Internal WebUI
-;    size_t bind_id;         // Bind ID
-;    size_t client_id;       // Client's unique ID
-;    size_t connection_id;   // Client's connection ID
-;    char* cookies;          // Client's full cookies
-;} webui_event_t;
 
 (define-cstruct _Webui_event_t
   (
@@ -81,12 +71,45 @@
    ))
 
 (define-struct webui-evt
-  (win event-type element event_number bind-id client-id connection-id cookies
+  (win event-type element event-number bind-id client-id connection-id cookies
        (data #:mutable))
   #:transparent
   )
 
-(define (queue-event c-evt-ptr)
+; ---------------------------------------------------------------------------
+; Thread-safe queue — dispatches C callbacks onto a Racket thread
+; async-channel is safe to put to from any OS thread (including WebUI's
+; WebSocket threads) and never allocates inside a GC atomic section.
+; ---------------------------------------------------------------------------
+
+;(define callback-queue (make-async-channel))
+
+(define (enqueue-callback thunk)
+  ; This does not work, as C memory will already be deallocated when the racket thread handles
+  ; the callback. 
+  ;(async-channel-put callback-queue thunk))
+  (thunk))
+
+; Any C callback created from a Racket procedure via (_fun #:keep callback-store ...)
+; is stored here, making it a permanent GC root. Without this, Racket CS's moving
+; GC can collect/relocate the trampoline between webui_interface_bind and invocation.
+(define callback-store (box '()))
+
+;(void
+;  (thread (lambda ()
+;            (let loop ()
+;              ((async-channel-get callback-queue))
+;              (loop)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Handling of bind events.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define bind-event-queue (make-queue))
+(define bind-event-sem   (make-semaphore))
+(define bind-callbacks   (make-hash))
+
+(define (handle-bind-event c-evt-ptr)
   (let ((evt (make-webui-evt
               (Webui_event_t-win c-evt-ptr)
               (Webui_event_t-event_type c-evt-ptr)
@@ -101,71 +124,63 @@
     (let ((count (webui_get_count c-evt-ptr)))
       (when (> count 0)
         (set-webui-evt-data! evt (webui_get_string_at c-evt-ptr 0))))
-    (enqueue! event-queue evt)
+    (enqueue! bind-event-queue evt)
+    ;(semaphore-post bind-event-sem)  ; In atomic mode no synchronization events
+    ; must be triggered.
+    ; As this is atomic mode, enqueue! will not interfere with dequeue!
     )
   )
 
-(define dispatcher-sem (make-semaphore))
-
-(define (enqueue-applyer queue-event-closure)
-  (start-atomic)
-  (queue-event-closure)
-  (end-atomic)
-  (semaphore-post dispatcher-sem)
+(define bind-event-dispatcher
+  (thread (λ ()
+            (letrec ((dispatch-loop
+                      (λ ()
+                        ;(semaphore-wait bind-event-sem)
+                        (when (> (queue-length bind-event-queue) 0)
+                          (displayln (queue->list bind-event-queue))
+                          (let* ((evt (dequeue! bind-event-queue))
+                                 (data (webui-evt-data evt))
+                                 (win (webui-evt-win evt))
+                                 (event-number (webui-evt-event-number evt)))
+                            (with-handlers ([exn:fail? (λ (e)
+                                                         (displayln
+                                                          (format "Event dispatching failed for: ~a" data))
+                                                         (displayln
+                                                          (format "Exception: ~a" e))
+                                                         (webui_interface_set_response win event-number "")
+                                                         )])
+                              (let* ((bind-evt (with-input-from-string data read-json))
+                                     (id (hash-ref bind-evt 'id #f))
+                                     (sel (hash-ref bind-evt 'selector 'any))
+                                     (event (hash-ref bind-evt 'evt #f))
+                                     (callback-id (string->symbol (format "sel-~a-~a" sel event)))
+                                     (cbs (hash-ref bind-callbacks win #f)))
+                                (cond
+                                  ([eq? cbs #f]
+                                   (error (format "No callbacks registered for window: ~a" win)))
+                                  (else
+                                   (let ((evt-handler (hash-ref cbs callback-id #f)))
+                                     (cond
+                                       ([eq? evt-handler #f]
+                                        (error (format "No callback registered for: ~a" callback-id)))
+                                       (else
+                                        (let ((result (evt-handler win id bind-evt)))
+                                          (webui_interface_set_response win event-number
+                                                                        (if (and result (not (void? result)))
+                                                                            (format "~a" result)
+                                                                            ""))))))))))))
+                        (unless (> (queue-length bind-event-queue) 0)
+                          (sleep 0.1))
+                        (dispatch-loop))))
+              (dispatch-loop))))
   )
 
-(define callbacks (make-hash))
-
-(define (event-dispatcher)
-  (thread
-   (λ ()
-     (letrec ((dispatcher
-               (λ ()
-                 (semaphore-wait dispatcher-sem)
-                 (let* ((evt (dequeue! event-queue))
-                        (data (webui-evt-data evt)))
-                   (with-handlers ([exn:fail?
-                                    (λ (e)
-                                      (displayln (format
-                                                  "Event dispatching failed for: ~a" data)))])
-                     (let ((e (with-input-from-string
-                                  data
-                                (λ () (read-json)))))
-                       (let ((id (hash-ref e 'id #f))
-                             (sel (hash-ref e 'selector 'any))
-                             (event (hash-ref e 'evt #f))
-                             (win (webui-evt-win evt)))
-                         (let ((cb-id (string->symbol (format "sel-~a-~a" sel event))))
-                           (let ((cbs (hash-ref callbacks win #f)))
-                             (if (eq? cbs #f)
-                                 (displayln (format "No callbacks registered for window: ~a" win))
-                                 (let ((evt-handler (hash-ref cbs cb-id #f)))
-                                   (if (eq? evt-handler #f)
-                                       (displayln (format "No callback registered for ~a" cb-id))
-                                       (evt-handler win id e)
-                                       )
-                                   )
-                                 )
-                             )
-                           )
-                         )
-                       )
-                     )
-                   )
-                 (dispatcher)
-                 )
-               ))
-       (dispatcher))
-     )
-   )
-  )
-
-(event-dispatcher)
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Log applier
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define timer-display (λ displ #t))
+
 (define debug-log (make-queue))
 
 (define (log-applier thunk)
@@ -175,95 +190,115 @@
   )
 
 (define (do-log level message data)
-  (enqueue! debug-log (list level (timer-display #f) message)))
+  (enqueue! debug-log (list level (timer-display #f)
+                            (bytes-copy message))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Serving virtual files...
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define timer-display (λ displ #t))
+(define file-handler-queue (make-queue))
+(define file-handler-sem   (make-semaphore))
+(define file-handler-file-providers (make-hash))
 
-(define request-sem (make-semaphore))
-
-(define (filehandler-applier thunk)
-  (start-atomic)
-  (thunk)
-  (end-atomic)
-  (semaphore-post request-sem)
-  )
-
-(define requested-files (make-queue))
-
-(define (fh-callback win filename length-ptr)
-  (enqueue! requested-files (list win filename (timer-display #f)))
-  #f)
+(define (file-handler-callback win filename length-ptr)
+  (let ((fn (format "~a" filename)))
+    (enqueue! file-handler-queue (list win fn (timer-display #f)))
+    ;(semaphore-post file-handler-sem)
+    #f ; return NULL and later set the data via async response
+    ))
 
 (define (make-reply file)
   (if (file-exists? file)
-      (if (or (string-suffix? file ".html")
-              (string-suffix? file ".htm"))
-          (let* ((size (file-size file))
-                 (fin (open-input-file file))
-                 (str (read-string size fin)))
-            (let ((reply (string-append
-                         "HTTP/1.1 200 OK\r\n"
-                         "Content-Type: text/html\r\n"
-                         (format "Content-Length: ~a\r\n\r\n" size)
-                         str)))
-              (close-input-port fin)
-              (list #t (string-length reply) reply)))
-          (list #f 0 ""))
-      (list #f 0 "")
+      (cond ((or (string-suffix? file ".html")
+                 (string-suffix? file ".htm")
+                 )
+             (let* ((size (file-size file))
+                    (fin (open-input-file file))
+                    (str (read-string size fin)))
+               (let ((reply (string->bytes/utf-8
+                             (string-append
+                             "HTTP/1.1 200 OK\r\n"
+                             "Content-Type: text/html\r\n"
+                             (format "Content-Length: ~a\r\n\r\n" size)
+                             str))))
+                 (close-input-port fin)
+                 (displayln (format "Returning http response of ~a bytes" (bytes-length reply)))
+                 (list #t (bytes-length reply) reply)))
+             )
+            (else (let* ((size (file-size file))
+                         (ext (substring (bytes->string/utf-8
+                                          (path-get-extension file)) 1))
+                         (fin (open-input-file file))
+                         (bytes (read-bytes size fin)))
+                    (let* ((hdr (string-append
+                                  "HTTP/1.1 200 OK\r\n"
+                                  (format "Content-Type: ~a\r\n" (ext->mimetype ext))
+                                  (format "Content-Length: ~a\r\n\r\n" size)
+                                  ))
+                           (reply (bytes-append (string->bytes/utf-8 hdr) bytes))
+                           )
+                      (close-input-port fin)
+                      (displayln (format "Returning http response of ~a bytes" (bytes-length reply)))
+                      (list #t (bytes-length reply) reply)))
+                  )
+            )
+      (begin
+        (displayln (format "File ~a does not exist" file))
+        (list #f 0 ""))
       )
   )
 
-(define (http-req-dispatcher)
+(define file-handler-dispatcher
   (thread
    (λ ()
-     (letrec ((dispatcher
+     (letrec ((dispatch-loop
                (λ ()
-                 (semaphore-wait request-sem)
-                 (timer-display)
-                 (let* ((req (dequeue! requested-files))
-                        (win (car req))
-                        (filename (cadr req))
-                        (time (caddr req))
-                        (reply (make-reply filename)))
-                   (displayln (format "http-req: ~a at ~a" filename time))
-                   (let ((valid-reply (car reply))
-                         (length (cadr reply))
-                         (content (caddr reply)))
-                     (if valid-reply
-                         (webui_interface_set_response_file_handler win
-                                                                    content
-                                                                    length)
-                         (webui_interface_set_response_file_handler win #f 0))
-                     )
-                   )
-                 (dispatcher))
+                 ;(semaphore-wait file-handler-sem)
+                 (when (> (queue-length file-handler-queue) 0)
+                   (timer-display)
+                   (displayln (queue->list file-handler-queue))
+                   (let* ((req (dequeue! file-handler-queue))
+                          (win (car req))
+                          (req-filename (cadr req))
+                          (filename ((hash-ref file-handler-file-providers win) req-filename))
+                          (time (caddr req))
+                          (reply (make-reply filename)))
+                     (displayln (format "http-req: ~a at ~a" filename time))
+                     (let ((valid-reply (car reply))
+                           (length (cadr reply))
+                           (content (caddr reply)))
+                       (if valid-reply
+                           (webui_interface_set_response_file_handler win content length)
+                           (webui_interface_set_response_file_handler win #f 0))
+                       )
+                     ))
+                 (unless (> (queue-length file-handler-queue) 0)
+                   (sleep 0.1))
+                 (dispatch-loop))
                ))
-       (dispatcher))
+       (dispatch-loop))
      )
    )
   )
 
-(http-req-dispatcher)
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; FFI functions
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define _Webui_Bind_Callback (_fun #:async-apply enqueue-applyer
-                                   _Webui_event_t-pointer -> _void))
-
 (define _int-pointer (_ptr i _int))
 
+(define _Webui_Bind_Callback
+  (_fun #:keep callback-store #:async-apply enqueue-callback
+        _Webui_event_t-pointer -> _void))
+
 (define _Webui_FileHandler_Callback
-  (_fun #:async-apply filehandler-applier _string/utf-8 _int-pointer -> _pointer))
+  (_fun #:keep callback-store #:async-apply enqueue-callback
+        _string/utf-8 _int-pointer -> _pointer))
 
 (define _Webui_FileHandlerWin_Callback
-  (_fun #:async-apply filehandler-applier _size_t _string/utf-8 _int-pointer -> _pointer))
-
+  (_fun #:keep callback-store #:async-apply enqueue-callback
+        _size_t _string/utf-8 _int-pointer -> _pointer))
 
 ;WEBUI_EXPORT bool webui_wait_async(void);
 (define-webui webui_wait_async (_fun -> _int))
@@ -320,7 +355,11 @@
 
 ;WEBUI_EXPORT void webui_interface_set_response_file_handler(size_t window, const void* response, int length);
 (define-webui webui_interface_set_response_file_handler
-  (_fun _size_t _pointer _int -> _void))
+  (_fun _size_t _bytes _int -> _void))
+
+;WEBUI_EXPORT void webui_interface_set_response(size_t window, size_t event_number, const char* response);
+(define-webui webui_interface_set_response
+  (_fun _size _size _string/utf-8 -> _void))
 
 ;WEBUI_EXPORT void webui_set_config(webui_config option, bool status);
 (define-webui webui_set_config
@@ -329,8 +368,8 @@
 ;WEBUI_EXPORT void webui_set_logger(void (*func)(size_t level, const char* log, void* user_data), void *user_data);
 (define-webui webui_set_logger
   (_fun
-   (_fun #:async-apply log-applier
-         _size_t _bytes _pointer -> _void)
+   (_fun #:keep callback-store #:async-apply enqueue-callback
+         _size_t _bytes/nul-terminated _pointer -> _void)
    _pointer -> _void))
 
 ;WEBUI_EXPORT const char* webui_start_server(size_t window, const char* content);
@@ -359,9 +398,13 @@
 
 (define (logger)
   (thread (λ ()
-            (add-to-log)
-            (sleep 0.1)
-            )))
+            (letrec ((f (λ ()
+                          (add-to-log)
+                          (sleep 0.1)
+                          (f))))
+              (f)
+              )))
+  )
 
 (define log-thread (logger))
 
@@ -396,7 +439,7 @@
 (define (webui-new-window)
   (let ((win (webui_new_window)))
     ;(webui_bind win "" queue-webui-event)
-    (webui_bind win "web_ui_wire_handle_event" queue-event)
+    (webui_bind win "web_ui_wire_handle_event" handle-bind-event)
     win))
 
 (define (webui-show win html)
@@ -438,28 +481,32 @@
                               evt
                               "');"
                               ))
-    (let ((cbs (hash-ref callbacks win (make-hash))))
+    (let ((cbs (hash-ref bind-callbacks win (make-hash))))
       (hash-set! cbs (string->symbol (format "sel-~a-~a" sel event)) callback)
-      (hash-set! callbacks win cbs))
+      (hash-set! bind-callbacks win cbs))
     )
   )
 
+(define (webui-set-file-handler-window win callback)
+  (hash-set! file-handler-file-providers win callback)
+  (webui_set_file_handler_window win file-handler-callback))
+
 (define (webui-register-move-callback win callback)
-    (let ((cbs (hash-ref callbacks win (make-hash))))
+    (let ((cbs (hash-ref bind-callbacks win (make-hash))))
       (hash-set! cbs (string->symbol "sel-global-window-move") callback)
-      (hash-set! callbacks win cbs))
+      (hash-set! bind-callbacks win cbs))
   )
 
 (define (webui-register-resize-callback win callback)
-    (let ((cbs (hash-ref callbacks win (make-hash))))
+    (let ((cbs (hash-ref bind-callbacks win (make-hash))))
       (hash-set! cbs (string->symbol "sel-global-window-resize") callback)
-      (hash-set! callbacks win cbs))
+      (hash-set! bind-callbacks win cbs))
   )
 
 (define (webui-register-onload-callback win callback)
-    (let ((cbs (hash-ref callbacks win (make-hash))))
+    (let ((cbs (hash-ref bind-callbacks win (make-hash))))
       (hash-set! cbs (string->symbol "sel-global-html-loaded") callback)
-      (hash-set! callbacks win cbs))
+      (hash-set! bind-callbacks win cbs))
   )
 
 (define (webui-wait-async)
@@ -470,7 +517,7 @@
 
 (define (webui-destroy win)
   (webui_destroy win)
-  ;(hash-remove! callbacks win)
+  (hash-remove! bind-callbacks win)
   )
 
 (define (webui-start-server win url)
@@ -492,7 +539,7 @@
           (displayln (format "~a" s)))
         s))))
 
-(webui_set_logger do-log #f)
+;(webui_set_logger do-log #f)
 
 (define win #f)
 (define (test)
@@ -503,7 +550,12 @@
     (tm)
     (webui-set-root-folder win "c:/devel/racket/racket-webui")
     (tm)
-    (webui_set_file_handler_window win fh-callback)
+    (webui-set-file-handler-window win
+                                   (λ (req-file)
+                                     (let ((file 
+                                            (format "c:/devel/racket/racket-webui~a" req-file)))
+                                     (displayln (format "file: ~a" file))
+                                       file)))
     (tm)
     (webui-register-onload-callback
      win
@@ -522,8 +574,8 @@
     (tm)
     ;(displayln (webui-start-server win "test.html"))
     (tm)
-    ;(webui-show-browser win "test.html")
-    (webui-show-wv win "test.html")
+    (webui-show-browser win "test.html")
+    ;(webui-show-wv win "test.html")
     (tm)
     )
   )