872 lines
30 KiB
Racket
872 lines
30 KiB
Racket
#lang racket/base
|
|
|
|
(require ffi/unsafe
|
|
ffi/unsafe/define
|
|
ffi/unsafe/atomic
|
|
ffi/unsafe/os-thread
|
|
ffi/unsafe/os-async-channel
|
|
ffi/unsafe/cvector
|
|
ffi/unsafe/custodian
|
|
racket/async-channel
|
|
racket/runtime-path
|
|
racket/port
|
|
data/queue
|
|
json
|
|
racket/string
|
|
racket/path
|
|
"private/utils.rkt"
|
|
"racket-webview-downloader.rkt"
|
|
openssl/libssl
|
|
)
|
|
|
|
(provide rkt-wv
|
|
rkt-wv-win
|
|
|
|
rkt-webview-new-context
|
|
rkt-webview-create
|
|
rkt-webview-close
|
|
rkt-webview-set-ou-token
|
|
rkt-webview-set-url!
|
|
rkt-webview-set-html!
|
|
rkt-webview-run-js
|
|
rkt-webview-call-js
|
|
rkt-webview-move
|
|
rkt-webview-resize
|
|
rkt-webview-show
|
|
rkt-webview-hide
|
|
rkt-webview-show-normal
|
|
rkt-webview-maximize
|
|
rkt-webview-minimize
|
|
rkt-webview-window-state
|
|
rkt-webview-set-title!
|
|
rkt-webview-set-icon!
|
|
rkt-webview-present
|
|
rkt-webview-exit
|
|
rkt-webview-valid?
|
|
rkt-webview-open-devtools
|
|
rkt-webview-choose-dir
|
|
rkt-webview-file-open
|
|
rkt-webview-file-save
|
|
rkt-webview-messagebox
|
|
rkt-webview-version
|
|
rkt-webview-set-loglevel
|
|
rkt-webview-info
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; FFI Library
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define lib-type 'release)
|
|
|
|
;; Check if racket-webview-qt backend is available or downloadable
|
|
|
|
(define do-ffi #t)
|
|
(define reason "")
|
|
|
|
(unless (racket-webview-qt-is-available?)
|
|
(if (racket-webview-qt-resolves?)
|
|
(if (racket-webview-qt-is-downloadable?)
|
|
(begin
|
|
(set! do-ffi (download-racket-webview-qt))
|
|
(when (eq? do-ffi #f)
|
|
(set! reason "Racket Webview Qt backend could not be downloaded"))
|
|
)
|
|
(begin
|
|
(displayln "There is no version of the racket-webview Qt backend available\n")
|
|
(displayln
|
|
(format "for OS '~a', Architecture '~a'"
|
|
(system-type 'os*)
|
|
(system-type 'arch)))
|
|
(set! do-ffi #f)
|
|
(set! reason (format
|
|
"There is no version of Racket Webview Qt for os '~a', architecture '~a' available"
|
|
(system-type 'os*)
|
|
(system-type 'arch)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(begin
|
|
(displayln "Warning: Cannot resolve racket webview download site.")
|
|
(displayln "Cannot download backend libraries and programs.")
|
|
(set! do-ffi #f)
|
|
(set! reason "Racket Webview Qt backend download site could not be resolved")
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Make sure we can load the FFI library, if at all possible (i.e. do-ffi equals #t)
|
|
|
|
(define os (system-type 'os*))
|
|
|
|
(define ffi-library
|
|
(cond
|
|
([eq? os 'windows] 'rktwebview.dll)
|
|
([eq? os 'linux] 'librktwebview.so)
|
|
)
|
|
)
|
|
|
|
(define os-lib-dir
|
|
(let ((dir (racket-webview-qt-directory)))
|
|
(if (eq? dir #f)
|
|
(build-path ".")
|
|
dir)))
|
|
|
|
(define (libname lib-symbol)
|
|
(build-path os-lib-dir (symbol->string lib-symbol)))
|
|
|
|
(define quiet-call #t)
|
|
|
|
(define rktwebview-prg (if (eq? os 'windows)
|
|
"rktwebview_prg.exe"
|
|
"rktwebview_prg"))
|
|
|
|
(define webengine-process (if (eq? os 'windows)
|
|
"QtWebEngineProcess.exe"
|
|
"QtWebEngineProcess"))
|
|
|
|
;;; Actual FFI integration
|
|
|
|
(define webview-lib-file (libname ffi-library))
|
|
(define webview-lib
|
|
(if (eq? do-ffi #f)
|
|
libssl
|
|
(with-handlers ([exn:fail?
|
|
(λ (exp)
|
|
(cond
|
|
([eq? os 'linux]
|
|
(error (format
|
|
(string-append "Cannot load ~a.\n"
|
|
"Make sure you installed Qt6 on your system\n"
|
|
"NB. the minimum Qt version that is supported is Qt 6.10.\n"
|
|
"This probably means you will need to install it separately from\n"
|
|
"the standard distro packages (e.g. libqt6webenginewidgets6 on\n"
|
|
"debian based systems).\n"
|
|
"\n"
|
|
"Exception:\n\n~a")
|
|
ffi-library exp)))
|
|
(else (error
|
|
(format "Cannot load ~a for os ~a\n\nException:\n\n~a"
|
|
ffi-library os exp))))
|
|
)
|
|
])
|
|
(ffi-lib webview-lib-file '("6" #f)
|
|
#:get-lib-dirs (list os-lib-dir)
|
|
;#:custodian (current-custodian)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Make sure we are forgiving with the function loading.
|
|
;; forgiving with the function loading.
|
|
|
|
(define (make-ffi-repl id err . ret)
|
|
(let ((warned #f)
|
|
(msg (if (eq? do-ffi #t)
|
|
(string-append
|
|
"'~a' could not be loaded from "
|
|
(format "~a" webview-lib-file))
|
|
(string-append
|
|
"'~a' could not be loaded.\n"
|
|
reason)))
|
|
)
|
|
(λ () (λ args
|
|
(if err
|
|
(error (format msg id))
|
|
(begin
|
|
(unless warned
|
|
(displayln (format msg id))
|
|
(set! warned #t))
|
|
(car ret)))))))
|
|
|
|
(define-ffi-definer define-rktwebview
|
|
webview-lib
|
|
#:default-make-fail (λ (id)
|
|
(if (eq? do-ffi #f)
|
|
(cond
|
|
((eq? id 'rkt_webview_env)
|
|
(make-ffi-repl id #f #t))
|
|
((eq? id 'rkt_webview_events_waiting)
|
|
(make-ffi-repl id #f 0))
|
|
((eq? id 'rkt_webview_init)
|
|
(make-ffi-repl id #f #t))
|
|
((eq? id 'rkt_webview_cleanup)
|
|
(make-ffi-repl id #f #t))
|
|
(else
|
|
(make-ffi-repl id #t))
|
|
)
|
|
(make-ffi-repl id #t)))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Types / Functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define _rkt_loglevel_t
|
|
(_enum '(error = 1
|
|
warning = 2
|
|
info = 3
|
|
debug = 4)
|
|
)
|
|
)
|
|
|
|
(define _rkt_result_t
|
|
(_enum '(no_result_yet = -1
|
|
oke = 0
|
|
set_html_failed = 1
|
|
set_navigate_failed = 2
|
|
eval_js_failed = 3
|
|
no_devtools_on_platform = 4
|
|
no_delegate_for_context = 5
|
|
webview_missing_dependency = 6
|
|
webview_canceled = 7
|
|
webview_invalid_state = 8
|
|
webview_invalid_argument = 9
|
|
webview_unspecified = 10
|
|
webview_dispatch_failed = 11
|
|
move_failed = 12
|
|
resize_failed = 13
|
|
choose_dir_failed = 14
|
|
open_file_failed = 15
|
|
save_file_failed = 16
|
|
failed = 17
|
|
invalid_handle = 18
|
|
)
|
|
)
|
|
)
|
|
|
|
(define _rkt_window_state_t
|
|
(_enum '(invalid = -1
|
|
normal = 0
|
|
minimized = 1
|
|
maximized = 2
|
|
hidden = 3
|
|
normal_active = 16
|
|
maximized_active = 18
|
|
)
|
|
)
|
|
)
|
|
|
|
(define _rkt_data_kind
|
|
(_enum '(version = -1
|
|
event = 2
|
|
js-result = 3
|
|
metrics = 4
|
|
)
|
|
)
|
|
)
|
|
|
|
(define _rkt_messagetype_t
|
|
(_enum '(info = 1
|
|
error = 2
|
|
warning = 3
|
|
yes-no = 4
|
|
oke-cancel = 5
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-cstruct _rkt_version_t
|
|
(
|
|
[api-major _int]
|
|
[api-minor _int]
|
|
[api-patch _int]
|
|
)
|
|
)
|
|
|
|
(define-cstruct _rkt_metrics_t
|
|
([shm_usage _int]
|
|
[shm_free_depth _int]
|
|
[shm_free_size _int]
|
|
[shm_item_depth _int]
|
|
[shm_item_size _int]
|
|
[shm_item_usage_factor _double]
|
|
[open_windows _int]
|
|
[function_calls _int]
|
|
[events _int]
|
|
[log_file _string*/utf-8]
|
|
)
|
|
)
|
|
|
|
(define-cstruct _rkt_evt_t
|
|
([w _int]
|
|
[evt _pointer]
|
|
))
|
|
|
|
(define-cstruct _rkt_js_result_t
|
|
([result _rkt_result_t]
|
|
[value _pointer]
|
|
))
|
|
|
|
(define-cstruct _rkt_data_t
|
|
([kind _rkt_data_kind]
|
|
[data (_union _rkt_version_t _rkt_evt_t _rkt_js_result_t _rkt_metrics_t)]
|
|
)
|
|
)
|
|
|
|
(define (evt-apply thunk)
|
|
(thunk))
|
|
|
|
;RKTWEBVIEW_EXPORT void rkt_webview_env(const char *env_cmds[]);
|
|
(define-rktwebview rkt_webview_env
|
|
(_fun _cvector -> _void))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT void rkt_webview_register_evt_callback(void (*f)(int));
|
|
(define-rktwebview rkt_webview_register_evt_callback
|
|
(_fun (_fun #:async-apply evt-apply #:atomic? #t
|
|
_int -> _void) -> _void))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT void rkt_webview_init(int &argc, char **argv);
|
|
(define-rktwebview rkt_webview_init
|
|
(_fun -> _void))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT void rkt_webview_cleanup();
|
|
(define-rktwebview rkt_webview_cleanup
|
|
(_fun -> _void))
|
|
|
|
;RKTWEBVIEW_EXPORT void rkt_webview_set_loglevel(rkt_webview_loglevel_t l);
|
|
(define-rktwebview rkt_webview_set_loglevel
|
|
(_fun _rkt_loglevel_t -> _void))
|
|
|
|
;RKTWEBVIEW_EXPORT rkt_data_t *rkt_webview_info();
|
|
(define-rktwebview rkt_webview_info
|
|
(_fun -> _rkt_data_t-pointer/null))
|
|
|
|
;RKTWEBVIEW_EXPORT int rkt_webview_events_waiting();
|
|
(define-rktwebview rkt_webview_events_waiting
|
|
(_fun -> _int))
|
|
|
|
;RKTWEBVIEW_EXPORT rkt_data_t *rkt_webview_get_event();
|
|
(define-rktwebview rkt_webview_get_event
|
|
(_fun -> _rkt_data_t-pointer/null))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT rkt_wv_context_t rkt_webview_new_context(const char *boilerplate_js,
|
|
; const char *optional_server_cert_pem);
|
|
(define-rktwebview rkt_webview_new_context
|
|
(_fun _string/utf-8 _string/utf-8 -> _int))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT void rkt_webview_process_events(int for_ms);
|
|
;(define-rktwebview rkt_webview_process_events
|
|
; (_fun _int -> _void))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT void rkt_webview_free_data(rkt_data_t *d);
|
|
(define-rktwebview rkt_webview_free_data
|
|
(_fun _rkt_data_t-pointer -> _void))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT rkt_data_t *rkt_webview_version();
|
|
(define-rktwebview rkt_webview_version
|
|
(_fun -> _rkt_data_t-pointer))
|
|
|
|
; RKTWEBVIEW_QT_EXPORT int rkt_webview_create(rkt_wv_context_t context,
|
|
; rktwebview_t parent)
|
|
(define-rktwebview rkt_webview_create
|
|
(_fun _int _int -> _int))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT void rkt_webview_close(int wv);
|
|
(define-rktwebview rkt_webview_close
|
|
(_fun _int -> _void))
|
|
|
|
;void rkt_webview_set_ou_token(rktwebview_t wv, const char *token)
|
|
(define-rktwebview rkt_webview_set_ou_token
|
|
(_fun _int _string/utf-8 -> _void))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_set_url(int wv, const char *url);
|
|
(define-rktwebview rkt_webview_set_url
|
|
(_fun _int _string/utf-8 -> _rkt_result_t))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_set_html(int wv, const char *html);
|
|
(define-rktwebview rkt_webview_set_html
|
|
(_fun _int _string/utf-8 -> _rkt_result_t))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_run_js(int wv, const char *js);
|
|
(define-rktwebview rkt_webview_run_js
|
|
(_fun _int _string/utf-8 -> _rkt_result_t))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT rkt_js_result_t *rkt_webview_call_js(rktwebview_t wv, const char *js);
|
|
(define-rktwebview rkt_webview_call_js
|
|
(_fun _int _string/utf-8 -> _rkt_data_t-pointer))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_open_devtools(int wv);
|
|
(define-rktwebview rkt_webview_open_devtools
|
|
(_fun _int -> _rkt_result_t))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_move(rktwebview_t w, int x, int y);
|
|
(define-rktwebview rkt_webview_move
|
|
(_fun _int _int _int -> _rkt_result_t))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_resize(rktwebview_t w, int width, int height);
|
|
(define-rktwebview rkt_webview_resize
|
|
(_fun _int _int _int -> _rkt_result_t))
|
|
|
|
(define-syntax def-rkt-wv
|
|
(syntax-rules ()
|
|
((_ name)
|
|
(define-rktwebview name
|
|
(_fun _int -> _rkt_result_t)))))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_hide(rktwebview_t w);
|
|
(def-rkt-wv rkt_webview_hide)
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_show(rktwebview_t w);
|
|
(def-rkt-wv rkt_webview_show)
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_show_normal(rktwebview_t w);
|
|
(def-rkt-wv rkt_webview_show_normal)
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_present(rktwebview_t w);
|
|
(def-rkt-wv rkt_webview_present)
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_maximize(rktwebview_t w);
|
|
(def-rkt-wv rkt_webview_maximize)
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_minimize(rktwebview_t w);
|
|
(def-rkt-wv rkt_webview_minimize)
|
|
|
|
;RKTWEBVIEW_QT_EXPORT bool rkt_webview_valid(rktwebview_t wv);
|
|
(define-rktwebview rkt_webview_valid
|
|
(_fun _int -> _int))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT window_state_t rkt_webview_window_state(rktwebview_t w);
|
|
(define-rktwebview rkt_webview_window_state
|
|
(_fun _int -> _rkt_window_state_t))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_set_title(rktwebview_t wv, const char *title);
|
|
(define-rktwebview rkt_webview_set_title
|
|
(_fun _int _string/utf-8 -> _rkt_result_t))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_set_icon(rktwebview_t wv, const char *icon-file);
|
|
(define-rktwebview rkt_webview_set_icon
|
|
(_fun _int _string/utf-8 -> _rkt_result_t))
|
|
|
|
|
|
;RKTWEBVIEW_QT_EXPORT rkt_js_result_t *rkt_webview_choose_dir(rktwebview_t w, const char *title, const char *base_dir);
|
|
(define-rktwebview rkt_webview_choose_dir
|
|
(_fun _int _string/utf-8 _string/utf-8 -> _rkt_result_t))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT rkt_js_result_t *rkt_webview_file_open(rktwebview_t w, const char *title, const char *base_dir, const char *permitted_exts);
|
|
(define-rktwebview rkt_webview_file_open
|
|
(_fun _int _string/utf-8 _string/utf-8 _string/utf-8 -> _rkt_result_t))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT rkt_js_result_t *rkt_webview_file_save(rktwebview_t w, const char *title, const char *base_dir, const char *permitted_exts);
|
|
(define-rktwebview rkt_webview_file_save
|
|
(_fun _int _string/utf-8 _string/utf-8 _string/utf-8 -> _rkt_result_t))
|
|
|
|
;RKTWEBVIEW_QT_EXPORT result_t rkt_webview_message_box(
|
|
; rktwebview_t w,
|
|
; const char *title,
|
|
; const char *message,
|
|
; const char *submessage,
|
|
; rkt_messagetype_t type);
|
|
(define-rktwebview rkt_webview_message_box
|
|
(_fun _int _string/utf-8 _string/utf-8 _string/utf-8 _rkt_messagetype_t -> _rkt_result_t))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Initialize and start library
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;(define process-events 'process)
|
|
|
|
;(define (stop-event-processing)
|
|
; (set! process-events 'stop)
|
|
; (while (eq? process-events 'stop)
|
|
; (sleep 0.001)))
|
|
|
|
;(define (start-event-processing)
|
|
; (thread (λ ()
|
|
; (letrec ((f (λ ()
|
|
; (rkt_webview_process_events 1)
|
|
; (sleep 0.001)
|
|
; (if (eq? process-events 'process)
|
|
; (f)
|
|
; (begin
|
|
; (displayln "Stopping event processing")
|
|
; (set! process-events 'stopped)
|
|
; 'done)))))
|
|
; (f)))))
|
|
|
|
(define rkt_env
|
|
(when (or (eq? os 'windows) (eq? os 'linux))
|
|
(let ((env (list (string-append "QT_PLUGIN_PATH=" (path->string (build-path os-lib-dir)))
|
|
(string-append "QTWEBENGINEPROCESS_PATH=" (path->string (build-path os-lib-dir webengine-process)))
|
|
(string-append "QTWEBENGINE_RESOURCES_PATH=" (path->string (build-path os-lib-dir "resources")))
|
|
(string-append "QTWEBENGINE_LOCALES_PATH=" (path->string (build-path os-lib-dir "translations" "qtwebengine_locales")))
|
|
(string-append "RKT_WEBVIEW_PRG=" (path->string (build-path os-lib-dir rktwebview-prg))))))
|
|
(when (eq? os 'linux)
|
|
(set! env (append
|
|
env
|
|
(list
|
|
(string-append "QT_QPA_PLATFORM=" "xcb")
|
|
(string-append "LD_LIBRARY_PATH="
|
|
(string-append
|
|
(path->string (build-path os-lib-dir)) ":"
|
|
(path->string (build-path os-lib-dir "platforms"))
|
|
)))))
|
|
)
|
|
(append env (list #f)))))
|
|
|
|
;(define env_array (_array _string/utf-8 (length rkt_env)))
|
|
|
|
;(let ((i 0))
|
|
; (while (< i (length rkt_env))
|
|
; (array-set! env_array i (list-ref rkt_env i))
|
|
; (set! i (+ i 1))))
|
|
|
|
(rkt_webview_env (list->cvector rkt_env _string/utf-8))
|
|
(rkt_webview_init)
|
|
|
|
(define events-channel (make-os-async-channel))
|
|
|
|
(define (event-callback num)
|
|
(os-async-channel-put events-channel num))
|
|
|
|
(rkt_webview_register_evt_callback event-callback)
|
|
|
|
;(set! quiet-call (start-event-processing))
|
|
(define evt-cb-hash (make-hash))
|
|
|
|
|
|
;; TODO Make this more semaphore like..
|
|
;; EG callback from library.
|
|
|
|
#|
|
|
(define (start-event-processing)
|
|
(thread (λ ()
|
|
(letrec ((f (λ ()
|
|
(let ((waiting (rkt_webview_events_waiting)))
|
|
;(displayln (format "Events waiting: ~a" waiting))
|
|
(while (> waiting 0)
|
|
(let* ((rkt-evt (rkt_webview_get_event)))
|
|
;(displayln rkt-evt)
|
|
(if (eq? rkt-evt #f)
|
|
(displayln (format "Unexpected: event = nullptr"))
|
|
(let ((data (rkt_data_t-data rkt-evt)))
|
|
;(displayln data)
|
|
(let ((e (union-ref data 1)))
|
|
; (displayln e)
|
|
(let ((wv (rkt_evt_t-w e)))
|
|
;(displayln wv)
|
|
(let ((evt (cast (rkt_evt_t-evt e) _pointer _string*/utf-8)))
|
|
; (displayln evt)
|
|
(rkt_webview_free_data rkt-evt)
|
|
(let ((cb (hash-ref evt-cb-hash wv #f)))
|
|
(unless (eq? cb #f)
|
|
(cb evt)))))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! waiting (- waiting 1))
|
|
)
|
|
)
|
|
(sleep 0.05)
|
|
(f))
|
|
))
|
|
(f)))
|
|
)
|
|
)
|
|
|#
|
|
|
|
(define alive-error-event -94328)
|
|
|
|
(define (close-down-on-alive-error)
|
|
(rkt-webview-exit #f
|
|
"rktwebview_prg has stopped working, cannot continue"
|
|
) ; close without closing windows
|
|
)
|
|
|
|
(define evt-guard-stop -93273)
|
|
|
|
(define (start-event-processing)
|
|
(thread (λ ()
|
|
(letrec
|
|
((f
|
|
(λ ()
|
|
(let ((waiting (sync events-channel)))
|
|
(if (= waiting evt-guard-stop)
|
|
(begin
|
|
(displayln "got evt-guard-stop, exiting event processing")
|
|
evt-guard-stop)
|
|
(begin
|
|
(set! waiting (rkt_webview_events_waiting))
|
|
(while (> waiting 0)
|
|
(let* ((rkt-evt (rkt_webview_get_event)))
|
|
(if (eq? rkt-evt #f)
|
|
(displayln (format "Unexpected: event = nullptr"))
|
|
(let* ((data (rkt_data_t-data rkt-evt))
|
|
(e (union-ref data 1))
|
|
(wv (rkt_evt_t-w e))
|
|
(evt (cast (rkt_evt_t-evt e)
|
|
_pointer
|
|
_string*/utf-8))
|
|
)
|
|
(rkt_webview_free_data rkt-evt)
|
|
;(displayln (format "~a ~a" wv evt))
|
|
(if (= wv alive-error-event)
|
|
(close-down-on-alive-error)
|
|
(let ((cb (hash-ref evt-cb-hash wv #f)))
|
|
(unless (eq? cb #f)
|
|
(cb evt)))))))
|
|
(set! waiting (- waiting 1))
|
|
)
|
|
(f))
|
|
)
|
|
)
|
|
)
|
|
))
|
|
(f))))
|
|
)
|
|
|
|
(define evt-processing-thread (start-event-processing))
|
|
|
|
(define (stop-event-processing)
|
|
(kill-thread evt-processing-thread))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provided features
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-struct rkt-wv
|
|
(win evt-queue callback [valid #:mutable] [close-callback #:mutable])
|
|
#:transparent
|
|
)
|
|
|
|
(define rkt-wv-store (make-hash))
|
|
|
|
#|
|
|
(define (rkt-process-events handle)
|
|
(if (> (queue-length (rkt-wv-evt-queue handle)) 0)
|
|
(let ((evt (dequeue! (rkt-wv-evt-queue handle))))
|
|
(if (symbol? evt)
|
|
(if (eq? evt 'quit)
|
|
(begin
|
|
(hash-remove! rkt-wv-store (rkt-wv-win handle))
|
|
'quit)
|
|
(begin
|
|
(warn-webview "Unexpected data in event queue: ~a" evt)
|
|
(rkt-process-events handle)))
|
|
(begin
|
|
((rkt-wv-callback handle) handle evt)
|
|
(rkt-process-events handle)))
|
|
)
|
|
'done)
|
|
)
|
|
|#
|
|
|
|
(define (rkt-webview-new-context boilerplate-js server-cert)
|
|
;(dbg-webview (format "boilerplate js: ~a" boilerplate-js))
|
|
;(dbg-webview (format "server-cert : ~a" server-cert))
|
|
(let ((r (rkt_webview_new_context boilerplate-js server-cert)))
|
|
r))
|
|
|
|
(define (rkt-webview-create context parent evt-callback close-callback)
|
|
(let* ((evt-queue (make-queue))
|
|
(parent-win (if (eq? parent #f) 0 (rkt-wv-win parent)))
|
|
)
|
|
(let ((wv (rkt_webview_create context parent-win)))
|
|
;(λ (evt) (enqueue! evt-queue evt)))
|
|
|
|
(let ((handle (make-rkt-wv wv evt-queue evt-callback #t close-callback)))
|
|
(hash-set! evt-cb-hash wv (λ (evt) (evt-callback handle evt)))
|
|
;(thread (λ ()
|
|
; (sleep 0.01)
|
|
; (letrec ((f (λ ()
|
|
; (let ((r (rkt-process-events handle)))
|
|
; (if (eq? r 'quit)
|
|
; (begin
|
|
; (set-rkt-wv-valid! handle #f)
|
|
; (info-webview "Quitting event loop")
|
|
; 'done)
|
|
; (begin
|
|
; ;(displayln "Waiting for events.")
|
|
; (sleep 0.01)
|
|
; (f)))))))
|
|
; (f))))
|
|
(hash-set! rkt-wv-store (rkt-wv-win handle) handle)
|
|
handle))))
|
|
|
|
(define (rkt-webview-close handle)
|
|
(rkt_webview_close (rkt-wv-win handle))
|
|
;(enqueue! (rkt-wv-evt-queue handle) 'quit)
|
|
(set-rkt-wv-valid! handle #f)
|
|
(hash-remove! evt-cb-hash (rkt-wv-win handle))
|
|
(hash-remove! rkt-wv-store (rkt-wv-win handle))
|
|
((rkt-wv-close-callback handle))
|
|
#t)
|
|
|
|
(define (rkt-webview-set-loglevel l)
|
|
(rkt_webview_set_loglevel l))
|
|
|
|
(define (rkt-webview-info)
|
|
(let* ((d (rkt_webview_info))
|
|
(r (union-ref (rkt_data_t-data d) 3))
|
|
)
|
|
(let ((res
|
|
(list (list 'shm-usage (rkt_metrics_t-shm_usage r))
|
|
(list 'shm-freelist (rkt_metrics_t-shm_free_depth r) (rkt_metrics_t-shm_free_size r))
|
|
(list 'shm-alloc (rkt_metrics_t-shm_item_depth r) (rkt_metrics_t-shm_item_size r) (rkt_metrics_t-shm_item_usage_factor r))
|
|
(list 'open-windows (rkt_metrics_t-open_windows r))
|
|
(list 'calls (rkt_metrics_t-function_calls r))
|
|
(list 'events (rkt_metrics_t-events r))
|
|
(list 'log-file (rkt_metrics_t-log_file r))
|
|
)))
|
|
(rkt_webview_free_data d)
|
|
res)))
|
|
|
|
(define (rkt-webview-set-ou-token handle token)
|
|
(rkt_webview_set_ou_token (rkt-wv-win handle) token)
|
|
#t)
|
|
|
|
(define (rkt-webview-set-url! wv url)
|
|
(rkt_webview_set_url (rkt-wv-win wv) url))
|
|
|
|
(define (rkt-webview-set-html! wv html)
|
|
(rkt_webview_set_html (rkt-wv-win wv) html))
|
|
|
|
(define (rkt-webview-set-title! wv title)
|
|
(rkt_webview_set_title (rkt-wv-win wv) title))
|
|
|
|
(define (rkt-webview-set-icon! wv icon-file)
|
|
(rkt_webview_set_icon (rkt-wv-win wv) icon-file))
|
|
|
|
(define (rkt-webview-run-js wv js)
|
|
(rkt_webview_run_js (rkt-wv-win wv) js))
|
|
|
|
(define (rkt-webview-call-js wv js)
|
|
(let* ((d (rkt_webview_call_js (rkt-wv-win wv) js))
|
|
(r (union-ref (rkt_data_t-data d) 2))
|
|
(value (cast (rkt_js_result_t-value r) _pointer _string*/utf-8))
|
|
(result (rkt_js_result_t-result r)))
|
|
(rkt_webview_free_data d)
|
|
(list result value)))
|
|
|
|
(define (rkt-webview-resize wv w h)
|
|
(rkt_webview_resize (rkt-wv-win wv) w h))
|
|
|
|
(define (rkt-webview-move wv x y)
|
|
(rkt_webview_move (rkt-wv-win wv) x y))
|
|
|
|
(define-syntax def-rkt-wrapper-wv
|
|
(syntax-rules ()
|
|
((_ name c-name)
|
|
(define (name wv)
|
|
(c-name (rkt-wv-win wv))))))
|
|
|
|
(def-rkt-wrapper-wv rkt-webview-show rkt_webview_show)
|
|
(def-rkt-wrapper-wv rkt-webview-hide rkt_webview_hide)
|
|
(def-rkt-wrapper-wv rkt-webview-show-normal rkt_webview_show_normal)
|
|
(def-rkt-wrapper-wv rkt-webview-minimize rkt_webview_minimize)
|
|
(def-rkt-wrapper-wv rkt-webview-maximize rkt_webview_maximize)
|
|
(def-rkt-wrapper-wv rkt-webview-present rkt_webview_present)
|
|
(def-rkt-wrapper-wv rkt-webview-window-state rkt_webview_window_state)
|
|
|
|
(define (rkt-webview-open-devtools wv)
|
|
(rkt_webview_open_devtools (rkt-wv-win wv)))
|
|
|
|
(define (rkt-webview-choose-dir wv title base-dir)
|
|
(rkt_webview_choose_dir (rkt-wv-win wv) title base-dir))
|
|
; (let* ((d (rkt_webview_choose_dir (rkt-wv-win wv) title base-dir))
|
|
; (r (union-ref (rkt_data_t-data d) 2))
|
|
; (value (cast (rkt_js_result_t-value r) _pointer _string*/utf-8))
|
|
; (result (rkt_js_result_t-result r)))
|
|
; (rkt_webview_free_data d)
|
|
; (list result value)))
|
|
|
|
(define (rkt-webview-file-open wv title base-dir permitted-exts)
|
|
(rkt_webview_file_open (rkt-wv-win wv) title base-dir permitted-exts))
|
|
; (let* ((d (rkt_webview_file_open (rkt-wv-win wv) title base-dir permitted-exts))
|
|
; (r (union-ref (rkt_data_t-data d) 2))
|
|
; (value (cast (rkt_js_result_t-value r) _pointer _string*/utf-8))
|
|
; (result (rkt_js_result_t-result r)))
|
|
; (rkt_webview_free_data d)
|
|
; (list result value)))
|
|
|
|
(define (rkt-webview-file-save wv title base-dir permitted-exts)
|
|
(rkt_webview_file_save (rkt-wv-win wv) title base-dir permitted-exts))
|
|
; (let* ((d (rkt_webview_file_save (rkt-wv-win wv) title base-dir permitted-exts))
|
|
; (r (union-ref (rkt_data_t-data d) 2))
|
|
; (value (cast (rkt_js_result_t-value r) _pointer _string*/utf-8))
|
|
; (result (rkt_js_result_t-result r)))
|
|
; (rkt_webview_free_data d)
|
|
; (list result value)))
|
|
|
|
(define (rkt-webview-messagebox wv title message submessage type)
|
|
(rkt_webview_message_box (rkt-wv-win wv) title message submessage type))
|
|
|
|
(define (rkt-webview-version)
|
|
(let ((d (rkt_webview_version)))
|
|
(let ((v (union-ref (rkt_data_t-data d) 0)))
|
|
(let ((api-major (rkt_version_t-api-major v))
|
|
(api-minor (rkt_version_t-api-minor v))
|
|
(api-patch (rkt_version_t-api-patch v))
|
|
)
|
|
(rkt_webview_free_data d)
|
|
(list (list 'webview-c-api api-major api-minor api-patch))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Administration
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (rkt-webview-valid? wv)
|
|
(if (eq? (rkt-wv-valid wv) #f)
|
|
#f
|
|
(if (= (rkt_webview_valid (rkt-wv-win wv)) 0)
|
|
#f
|
|
#t)))
|
|
|
|
|
|
(define (rkt-webview-finalizer rkt-wv-store close-windows message)
|
|
(displayln "rkt-webview-finalizer active")
|
|
(when close-windows
|
|
(let ((open-windows (hash->list rkt-wv-store)))
|
|
(for-each (λ (kv)
|
|
(let ((win (car kv))
|
|
(handle (cdr kv)))
|
|
(rkt-webview-close handle)))
|
|
open-windows)))
|
|
(displayln "Sending guard-stop message to event callback")
|
|
(event-callback evt-guard-stop)
|
|
(displayln "Cleaning up FFI library")
|
|
(rkt_webview_cleanup)
|
|
(unless (eq? message #f) (error message))
|
|
(displayln "Stopping event processing thread (kill-thread)"
|
|
(stop-event-processing)
|
|
(displayln "Finalizer done")
|
|
)
|
|
|
|
(define (rkt-webview-exit . args)
|
|
(let ((cl-w (if (null? args) #t (car args)))
|
|
(msg (if (null? args) #f
|
|
(if (null? (cdr args))
|
|
#f
|
|
(cadr args))))
|
|
)
|
|
(rkt-webview-finalizer rkt-wv-store cl-w msg)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Cleanup on exit
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
#|
|
|
(set! quiet-call
|
|
(plumber-add-flush! (current-plumber)
|
|
(λ (handle)
|
|
(rkt-webview-exit))))
|
|
|#
|
|
|
|
(define custodian-finalizer
|
|
(register-custodian-shutdown rkt-wv-store
|
|
(λ (rkt-wv-store)
|
|
(rkt-webview-finalizer rkt-wv-store #t #f))
|
|
#:at-exit? #t)
|
|
)
|
|
|
|
|
|
|