Files
racket-webview/private/racket-webview-qt.rkt

620 lines
20 KiB
Racket

#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
ffi/unsafe/atomic
ffi/unsafe/os-thread
racket/async-channel
racket/runtime-path
racket/port
data/queue
json
racket/string
racket/path
"utils.rkt"
)
(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-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
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FFI Library
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define lib-type 'release)
(define os (system-type 'os*))
(define arch (system-type 'arch))
(define supported-os '(windows linux))
(unless (ormap (λ (o) (eq? os o)) supported-os)
(error (format "OS currently not supported: ~a. Supported: ~a." os supported-os)))
(define-runtime-path lib-dir "lib")
(define libraries-to-preload
(cond
([eq? os 'windows]
'(Qt6Core.dll
Qt6Positioning.dll
Qt6Gui.dll
Qt6Widgets.dll
Qt6Svg.dll
Qt6Network.dll
Qt6OpenGL.dll
Qt6PrintSupport.dll
Qt6Qml.dll
Qt6QmlModels.dll
Qt6QmlWorkerScript.dll
Qt6QmlMeta.dll
Qt6Quick.dll
Qt6QuickWidgets.dll
Qt6WebChannel.dll
Qt6WebEngineCore.dll
Qt6WebEngineWidgets.dll
))
([eq? os 'linux]
'(libQt6XcbQpa
;libQt6WaylandClient
;libQt6EglFSDeviceIntegration
libQt6Core
libQt6Positioning
libQt6Gui
libQt6Widgets
libQt6Svg
libQt6Network
libQt6OpenGL
libQt6PrintSupport
libQt6Qml
libQt6QmlModels
libQt6QmlWorkerScript
libQt6QmlMeta
libQt6Quick
libQt6QuickWidgets
libQt6WebChannel
libQt6WebEngineCore
libQt6WebEngineWidgets
))
)
)
(define ffi-library
(cond
([eq? os 'windows] 'rktwebview_qt.dll)
([eq? os 'linux] 'librktwebview_qt.so)
)
)
(define os-lib-dir (build-path lib-dir (symbol->string os) (symbol->string arch)))
(define (libname lib-symbol)
(build-path os-lib-dir (symbol->string lib-symbol)))
; c:\qt\6.10.2\msvc2022_64\bin\windeployqt.exe rktwebview_qt_test.exe
(define quiet-call #t)
(set! quiet-call
(when (or (eq? os 'windows) (eq? os 'linux))
(putenv "QT_PLUGIN_PATH"
(path->string (build-path os-lib-dir)))
(putenv "QTWEBENGINEPROCESS_PATH"
(path->string (build-path os-lib-dir "QtWebEngineProcess.exe")))
(putenv "QTWEBENGINE_RESOURCES_PATH"
(path->string (build-path os-lib-dir "resources")))
(putenv "QTWEBENGINE_LOCALES_PATH"
(path->string (build-path os-lib-dir "translations" "qtwebengine_locales")))
(when (eq? os 'linux)
(putenv "QT_QPA_PLATFORM" "xcb")
(putenv "LD_LIBRARY_PATH"
(string-append
(path->string (build-path os-lib-dir)) ":"
(path->string (build-path os-lib-dir "platforms"))
)
)
)
)
)
;;; Preload libraries
(for-each (λ (lib-symbol)
(let* ((libn (if (list? lib-symbol) (car lib-symbol) lib-symbol))
(versions (if (list? lib-symbol) (cons (cadr lib-symbol) '(#f)) (list #f)))
(load-lib (if (list? lib-symbol)
(if (eq? (caddr lib-symbol) #f)
(symbol->string libn)
(libname libn))
(libname libn)))
)
;(displayln (format "loading ~a" load-lib))
(ffi-lib load-lib versions)
)
)
libraries-to-preload)
;;; Actual FFI integration
(define webview-lib-file (libname ffi-library))
(define webview-lib
(with-handlers ([exn:fail?
(λ (exp)
(cond
([eq? os 'linux]
(error (format
(string-append "Cannot load ~a.\n"
"Make sure you installed Qt6on your system\n"
"e.g. on debian 'sudo apt install libqt6webenginewidgets6'\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))))
(define-ffi-definer define-rktwebview webview-lib)
;;; Callbacks from the OS library
(define callback-box (box '()))
(define (applier thunk)
(thunk))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Types / Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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
move_failed = 12
resize_failed = 13
)
)
)
(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
)
)
)
(define _rkt_messagetype_t
(_enum '(info = 1
error = 2
warning = 3
yes-no = 4
oke-cancel = 5
)
)
)
(define-cstruct _rkt_version_t
([qt-major _int]
[qt-minor _int]
[qt-patch _int]
[api-major _int]
[api-minor _int]
[api-patch _int]
)
)
(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)]
)
)
;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_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 _bytes -> _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,
; event_cb_t js_event_cb);
(define-rktwebview rkt_webview_create
(_fun _int _int
(_fun #:keep callback-box #:async-apply applier
_rkt_data_t-pointer -> _void)
-> _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 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)))))
(rkt_webview_init)
(set! quiet-call (start-event-processing))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
(displayln (format "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)
(rkt_webview_new_context boilerplate-js server-cert))
(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
(λ (rkt-evt)
(let* ((e (union-ref (rkt_data_t-data rkt-evt) 1))
(evt (cast (rkt_evt_t-evt e) _pointer _string*/utf-8)))
(rkt_webview_free_data rkt-evt) ; Free event data ASAP
(enqueue! evt-queue evt)
)))))
(let ((handle (make-rkt-wv wv evt-queue evt-callback #t close-callback)))
(thread (λ ()
(sleep 1)
(letrec ((f (λ ()
(let ((r (rkt-process-events handle)))
(if (eq? r 'quit)
(begin
(set-rkt-wv-valid! handle #f)
(displayln "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)
((rkt-wv-close-callback handle))
#t)
(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-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 ((qt-major (rkt_version_t-qt-major v))
(qt-minor (rkt_version_t-qt-minor v))
(qt-patch (rkt_version_t-qt-patch v))
(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)
(list 'qt qt-major qt-minor qt-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-exit)
(let ((open-windows (hash->list rkt-wv-store)))
(for-each (λ (kv)
(let ((win (car kv))
(handle (cdr kv)))
(rkt-webview-close handle)))
open-windows))
(stop-event-processing)
(rkt_webview_cleanup)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Cleanup on exit
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(set! quiet-call
(plumber-add-flush! (current-plumber)
(λ (handle)
(rkt-webview-exit))))