526 lines
16 KiB
Racket
526 lines
16 KiB
Racket
#lang racket/base
|
|
|
|
(require ffi/unsafe
|
|
ffi/unsafe/define
|
|
ffi/unsafe/atomic
|
|
racket/runtime-path
|
|
racket/port
|
|
data/queue
|
|
json
|
|
racket/string
|
|
)
|
|
|
|
(provide webui-new-window
|
|
webui-show
|
|
webui-bind
|
|
webui-wait-async
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; FFI Library
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-runtime-path lib-dir "lib")
|
|
|
|
(define libname (let ((os (system-type 'os*)))
|
|
(cond ((eq? os 'windows) "dll/webui-2.dll")
|
|
(else (error (format "OS ~a not supported" os)))))
|
|
)
|
|
|
|
(define webui-lib-file (build-path lib-dir libname))
|
|
|
|
(set! webui-lib-file "C:/devel/racket/racket-webui/webui/build/Debug/webui-2.dll")
|
|
|
|
|
|
(define webui-lib (ffi-lib webui-lib-file))
|
|
(define-ffi-definer define-webui webui-lib)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Types
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define _size_t _int64)
|
|
|
|
(define _webui_config_t
|
|
(_enum '(show-wait-connection = 0
|
|
ui-event-blocking
|
|
folder-monitor
|
|
multi-client
|
|
use-cookies
|
|
asynchronous-response
|
|
)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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
|
|
(
|
|
[win _size_t]
|
|
[event_type _size_t]
|
|
[element _string/utf-8]
|
|
[event_number _size_t]
|
|
[bind_id _size_t]
|
|
[client_id _size_t]
|
|
[connection_id _size_t]
|
|
[cookies _string/utf-8]
|
|
))
|
|
|
|
(define-struct webui-evt
|
|
(win event-type element event_number bind-id client-id connection-id cookies
|
|
(data #:mutable))
|
|
#:transparent
|
|
)
|
|
|
|
(define (queue-event c-evt-ptr)
|
|
(let ((evt (make-webui-evt
|
|
(Webui_event_t-win c-evt-ptr)
|
|
(Webui_event_t-event_type c-evt-ptr)
|
|
(Webui_event_t-element c-evt-ptr)
|
|
(Webui_event_t-event_number c-evt-ptr)
|
|
(Webui_event_t-bind_id c-evt-ptr)
|
|
(Webui_event_t-client_id c-evt-ptr)
|
|
(Webui_event_t-connection_id c-evt-ptr)
|
|
(Webui_event_t-cookies c-evt-ptr)
|
|
#f
|
|
)))
|
|
(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)
|
|
)
|
|
)
|
|
|
|
(define dispatcher-sem (make-semaphore))
|
|
|
|
(define (enqueue-applyer queue-event-closure)
|
|
(start-atomic)
|
|
(queue-event-closure)
|
|
(end-atomic)
|
|
(semaphore-post dispatcher-sem)
|
|
)
|
|
|
|
(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 debug-log (make-queue))
|
|
|
|
(define (log-applier thunk)
|
|
(start-atomic)
|
|
(thunk)
|
|
(end-atomic)
|
|
)
|
|
|
|
(define (do-log level message data)
|
|
(enqueue! debug-log (list level (timer-display #f) message)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Serving virtual files...
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define timer-display (λ displ #t))
|
|
|
|
(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 (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 "")
|
|
)
|
|
)
|
|
|
|
(define (http-req-dispatcher)
|
|
(thread
|
|
(λ ()
|
|
(letrec ((dispatcher
|
|
(λ ()
|
|
(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))
|
|
))
|
|
(dispatcher))
|
|
)
|
|
)
|
|
)
|
|
|
|
(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_FileHandler_Callback
|
|
(_fun #:async-apply filehandler-applier _string/utf-8 _int-pointer -> _pointer))
|
|
|
|
(define _Webui_FileHandlerWin_Callback
|
|
(_fun #:async-apply filehandler-applier _size_t _string/utf-8 _int-pointer -> _pointer))
|
|
|
|
|
|
;WEBUI_EXPORT bool webui_wait_async(void);
|
|
(define-webui webui_wait_async (_fun -> _int))
|
|
|
|
;WEBUI_EXPORT size_t webui_new_window(void);
|
|
(define-webui webui_new_window (_fun -> _size_t))
|
|
|
|
;WEBUI_EXPORT size_t webui_bind(size_t window, const char* element, void (*func)(webui_event_t* e));
|
|
(define-webui webui_bind (_fun _size_t _string/utf-8 _Webui_Bind_Callback -> _size_t))
|
|
|
|
;WEBUI_EXPORT bool webui_show(size_t window, const char* content);
|
|
(define-webui webui_show (_fun _size_t _string/utf-8 -> _int))
|
|
|
|
;WEBUI_EXPORT bool webui_show_browser(size_t window, const char* content, size_t browser);
|
|
(define-webui webui_show_browser (_fun _size_t _string/utf-8 _size_t -> _int))
|
|
|
|
;WEBUI_EXPORT void webui_exit(void);
|
|
(define-webui webui_exit (_fun -> _void))
|
|
|
|
;WEBUI_EXPORT void webui_destroy(size_t window);
|
|
(define-webui webui_destroy (_fun _size_t -> _void))
|
|
|
|
;WEBUI_EXPORT void webui_close(size_t window);
|
|
(define-webui webui_close (_fun _size_t -> _void))
|
|
|
|
;WEBUI_EXPORT bool webui_set_root_folder(size_t window, const char* path);
|
|
(define-webui webui_set_root_folder (_fun _size_t _string/utf-8 -> _int))
|
|
|
|
;WEBUI_EXPORT void webui_run(size_t window, const char* script);
|
|
(define-webui webui_run (_fun _size_t _string/utf-8 -> _void))
|
|
|
|
;WEBUI_EXPORT size_t webui_get_count(webui_event_t* e);
|
|
(define-webui webui_get_count (_fun _Webui_event_t-pointer -> _size_t))
|
|
|
|
;WEBUI_EXPORT long long int webui_get_int_at(webui_event_t* e, size_t index);
|
|
(define-webui webui_get_int_at (_fun _Webui_event_t-pointer _size_t -> _int64))
|
|
|
|
;WEBUI_EXPORT double webui_get_float_at(webui_event_t* e, size_t index);
|
|
(define-webui webui_get_float_at (_fun _Webui_event_t-pointer _size_t -> _double))
|
|
|
|
;WEBUI_EXPORT const char* webui_get_string_at(webui_event_t* e, size_t index);
|
|
(define-webui webui_get_string_at (_fun _Webui_event_t-pointer _size_t -> _string/utf-8))
|
|
|
|
;WEBUI_EXPORT void webui_set_file_handler(size_t window, const void* (*handler)(const char* filename, int* length));
|
|
(define-webui webui_set_file_handler
|
|
(_fun _size_t _Webui_FileHandler_Callback -> _void))
|
|
|
|
;WEBUI_EXPORT void webui_set_file_handler_window(size_t window, const void* (*handler)(size_t window, const char* filename, int* length));
|
|
(define-webui webui_set_file_handler_window
|
|
(_fun _size_t _Webui_FileHandlerWin_Callback -> _void))
|
|
|
|
;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))
|
|
|
|
;WEBUI_EXPORT void webui_set_config(webui_config option, bool status);
|
|
(define-webui webui_set_config
|
|
(_fun _webui_config_t _int -> _void))
|
|
|
|
;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 _string/utf-8 _pointer -> _void)
|
|
_pointer -> _void))
|
|
|
|
;WEBUI_EXPORT const char* webui_start_server(size_t window, const char* content);
|
|
(define-webui webui_start_server
|
|
(_fun _size_t _string/utf-8 -> _string/utf-8))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Configure
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(webui_set_config 'asynchronous-response 1)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Async Wait loop as co-routine
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define run-async-thread #f)
|
|
(define log-fh (open-output-file "test.log" #:exists 'replace))
|
|
|
|
(define (add-to-log)
|
|
(if (> (queue-length debug-log) 0)
|
|
(begin
|
|
(display (dequeue! debug-log) log-fh)
|
|
(add-to-log))
|
|
(flush-output log-fh)))
|
|
|
|
(define (logger)
|
|
(thread (λ ()
|
|
(add-to-log)
|
|
(sleep 0.1)
|
|
)))
|
|
|
|
(define log-thread (logger))
|
|
|
|
(define (finish-log)
|
|
(kill-thread log-thread)
|
|
(add-to-log)
|
|
(close-output-port log-fh))
|
|
|
|
|
|
(define (run-async-wait)
|
|
(when (or (eq? run-async-thread #f)
|
|
(not (thread-running? run-async-thread)))
|
|
(set! run-async-thread
|
|
(thread (λ ()
|
|
(letrec ((wait-loop
|
|
(λ ()
|
|
(let ((r (webui_wait_async))) ; Returns true if windows are open
|
|
(when (eq? r #t)
|
|
(sleep 0.1)
|
|
(wait-loop))))))
|
|
(wait-loop)))
|
|
#:pool #f
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provided functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(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)
|
|
win))
|
|
|
|
(define (webui-show win html)
|
|
(webui_show win html)
|
|
(run-async-wait)
|
|
)
|
|
|
|
(define (webui-show-browser win html)
|
|
(webui_show_browser win html 1)
|
|
(run-async-wait)
|
|
)
|
|
|
|
(define (webui-run win js)
|
|
(webui_run win js))
|
|
|
|
(define (webui-set-config option status)
|
|
(webui_set_config option status))
|
|
|
|
(define (webui-bind win selector event callback)
|
|
(let ((sel (if (symbol? selector)
|
|
(format "#~a" selector)
|
|
selector))
|
|
(evt (if (symbol? event)
|
|
(format "~a" event)
|
|
event))
|
|
)
|
|
(webui-run win
|
|
(string-append "window._web_wire_bind_evt_ids("
|
|
(format "~a" win)
|
|
", '"
|
|
sel
|
|
"', '"
|
|
evt
|
|
"');"
|
|
))
|
|
(let ((cbs (hash-ref callbacks win (make-hash))))
|
|
(hash-set! cbs (string->symbol (format "sel-~a-~a" sel event)) callback)
|
|
(hash-set! callbacks win cbs))
|
|
)
|
|
)
|
|
|
|
(define (webui-register-move-callback win callback)
|
|
(let ((cbs (hash-ref callbacks win (make-hash))))
|
|
(hash-set! cbs (string->symbol "sel-global-window-move") callback)
|
|
(hash-set! callbacks win cbs))
|
|
)
|
|
|
|
(define (webui-register-resize-callback win callback)
|
|
(let ((cbs (hash-ref callbacks win (make-hash))))
|
|
(hash-set! cbs (string->symbol "sel-global-window-resize") callback)
|
|
(hash-set! callbacks win cbs))
|
|
)
|
|
|
|
(define (webui-register-onload-callback win callback)
|
|
(let ((cbs (hash-ref callbacks win (make-hash))))
|
|
(hash-set! cbs (string->symbol "sel-global-html-loaded") callback)
|
|
(hash-set! callbacks win cbs))
|
|
)
|
|
|
|
(define (webui-wait-async)
|
|
(webui_wait_async))
|
|
|
|
(define (webui-close win)
|
|
(webui_close win))
|
|
|
|
(define (webui-destroy win)
|
|
(webui_destroy win)
|
|
;(hash-remove! callbacks win)
|
|
)
|
|
|
|
(define (webui-start-server win url)
|
|
(webui_start_server win url))
|
|
|
|
(define (webui-exit)
|
|
(webui_exit))
|
|
|
|
(define (webui-set-root-folder win path)
|
|
(let ((p (if (path? path) (path->string path) path)))
|
|
(webui_set_root_folder win p)))
|
|
|
|
(define (timer)
|
|
(let ((ms (current-milliseconds)))
|
|
(λ displ
|
|
(let* ((dms (- (current-milliseconds) ms))
|
|
(s (exact->inexact (/ dms 1000))))
|
|
(when (null? displ)
|
|
(displayln (format "~a" s)))
|
|
s))))
|
|
|
|
(webui_set_logger do-log #f)
|
|
|
|
(define win #f)
|
|
(define (test)
|
|
(let ((tm (timer)))
|
|
(set! timer-display tm)
|
|
(tm)
|
|
(set! win (webui-new-window))
|
|
(tm)
|
|
(webui-set-root-folder win "c:/devel/racket/racket-webui")
|
|
(tm)
|
|
;(webui_set_file_handler_window win fh-callback)
|
|
(tm)
|
|
(webui-register-onload-callback
|
|
win
|
|
(λ (win id data)
|
|
(webui-bind win "button" 'click
|
|
(λ (win id data)
|
|
(displayln (format "~a: ~a" id data)))
|
|
)
|
|
)
|
|
)
|
|
(tm)
|
|
(webui-register-move-callback win (λ (win id data)
|
|
(displayln data)))
|
|
(webui-register-resize-callback win (λ (win id data)
|
|
(displayln data)))
|
|
(tm)
|
|
;(displayln (webui-start-server win "test.html"))
|
|
(tm)
|
|
(webui-show-browser win "test.html")
|
|
(tm)
|
|
)
|
|
)
|
|
|
|
|
|
(define (test-close)
|
|
(webui-close win)
|
|
(webui-destroy win))
|
|
|