960 lines
29 KiB
Racket
960 lines
29 KiB
Racket
#lang racket/base
|
|
|
|
(require data/queue
|
|
json
|
|
racket/async-channel
|
|
racket/file
|
|
racket/list
|
|
racket/path
|
|
racket/port
|
|
racket/string
|
|
racket/system
|
|
"private/utils.rkt"
|
|
"racket-webview-downloader.rkt"
|
|
"menu.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-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
|
|
|
|
rkt-webview-tray-create
|
|
rkt-webview-tray-set-icon!
|
|
rkt-webview-tray-set-tooltip!
|
|
rkt-webview-tray-show-message
|
|
rkt-webview-tray-set-menu!)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Protocol constants
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define cmd-handle-is-valid 1)
|
|
(define cmd-quit 2)
|
|
(define cmd-context-new 3)
|
|
(define cmd-create-wv 4)
|
|
(define cmd-close-wv 5)
|
|
(define cmd-set-url 6)
|
|
(define cmd-set-html 7)
|
|
(define cmd-run-js 8)
|
|
(define cmd-call-js 9)
|
|
(define cmd-open-devtools 10)
|
|
(define cmd-move 11)
|
|
(define cmd-resize 12)
|
|
(define cmd-hide 13)
|
|
(define cmd-show 14)
|
|
(define cmd-present 15)
|
|
(define cmd-maximize 16)
|
|
(define cmd-minimize 17)
|
|
(define cmd-show-normal 18)
|
|
(define cmd-window-state 19)
|
|
(define cmd-set-title 20)
|
|
(define cmd-choose-dir 21)
|
|
(define cmd-file-open 22)
|
|
(define cmd-file-save 23)
|
|
(define cmd-set-ou-token 24)
|
|
(define cmd-msg-box 25)
|
|
(define cmd-set-loglevel 26)
|
|
(define cmd-info 27)
|
|
(define cmd-set-icon 28)
|
|
(define cmd-create-tray 29)
|
|
(define cmd-tray-set-icon 30)
|
|
(define cmd-tray-set-tooltip 31)
|
|
(define cmd-tray-show-message 32)
|
|
(define cmd-tray-set-menu 33)
|
|
(define cmd-tray-clear-menu 34)
|
|
|
|
(define stdio-protocol-version 1)
|
|
|
|
(define (result-code->symbol code)
|
|
(case code
|
|
((-1) 'no_result_yet)
|
|
((0) 'oke)
|
|
((1) 'set_html_failed)
|
|
((2) 'set_navigate_failed)
|
|
((3) 'eval_js_failed)
|
|
((4) 'no_devtools_on_platform)
|
|
((5) 'no_delegate_for_context)
|
|
((6) 'webview_missing_dependency)
|
|
((7) 'webview_canceled)
|
|
((8) 'webview_invalid_state)
|
|
((9) 'webview_invalid_argument)
|
|
((10) 'webview_unspecified)
|
|
((11) 'webview_dispatch_failed)
|
|
((12) 'move_failed)
|
|
((13) 'resize_failed)
|
|
((14) 'choose_dir_failed)
|
|
((15) 'open_file_failed)
|
|
((16) 'save_file_failed)
|
|
((17) 'failed)
|
|
((18) 'invalid_handle)
|
|
(else 'failed)))
|
|
|
|
(define (window-state-code->symbol code)
|
|
(case code
|
|
((-1) 'invalid)
|
|
((0) 'normal)
|
|
((1) 'minimized)
|
|
((2) 'maximized)
|
|
((3) 'hidden)
|
|
((16) 'normal_active)
|
|
((18) 'maximized_active)
|
|
(else 'invalid)))
|
|
|
|
(define (loglevel->integer level)
|
|
(case level
|
|
((error) 1)
|
|
((warning) 2)
|
|
((info) 3)
|
|
((debug) 4)
|
|
(else (error 'rkt-webview-set-loglevel
|
|
"expected 'error, 'warning, 'info or 'debug; got ~a"
|
|
level))))
|
|
|
|
(define (messagetype->integer type)
|
|
(case type
|
|
((info) 1)
|
|
((error) 2)
|
|
((warning) 3)
|
|
((yes-no) 4)
|
|
((oke-cancel) 5)
|
|
(else (error 'rkt-webview-messagebox
|
|
"unknown message type: ~a"
|
|
type))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Backend location and child environment
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define os (system-type 'os*))
|
|
|
|
(define rktwebview-prg
|
|
(if (eq? os 'windows)
|
|
"rktwebview_prg.exe"
|
|
"rktwebview_prg"))
|
|
|
|
(define webengine-process
|
|
(if (eq? os 'windows)
|
|
"QtWebEngineProcess.exe"
|
|
"QtWebEngineProcess"))
|
|
|
|
(define backend-program #f)
|
|
(define backend-directory #f)
|
|
|
|
(define (executable-file? path)
|
|
;; Let subprocess report a platform-specific execute error. Checking only
|
|
;; existence also works for Windows and for unpacked Unix release archives.
|
|
(and path (file-exists? path)))
|
|
|
|
(define (ensure-backend-program!)
|
|
(unless backend-program
|
|
(let ((override (getenv "RKT_WEBVIEW_PRG")))
|
|
(cond
|
|
((and override (executable-file? override))
|
|
(set! backend-program (path->complete-path override))
|
|
(set! backend-directory (path-only backend-program)))
|
|
|
|
(override
|
|
(error 'racket-webview
|
|
"RKT_WEBVIEW_PRG does not point to an executable file: ~a"
|
|
override))
|
|
|
|
(else
|
|
(unless (racket-webview-qt-is-available?)
|
|
(cond
|
|
((not (racket-webview-qt-resolves?))
|
|
(error 'racket-webview
|
|
"Cannot resolve the racket-webview-qt download site"))
|
|
((not (racket-webview-qt-is-downloadable?))
|
|
(error 'racket-webview
|
|
(string-append
|
|
"No downloadable racket-webview-qt backend is available "
|
|
"for OS ~a and architecture ~a")
|
|
os
|
|
(system-type 'arch)))
|
|
((not (download-racket-webview-qt))
|
|
(error 'racket-webview
|
|
"The racket-webview-qt backend could not be downloaded"))))
|
|
|
|
(set! backend-directory (racket-webview-qt-directory))
|
|
(set! backend-program (build-path backend-directory rktwebview-prg))
|
|
(unless (executable-file? backend-program)
|
|
(error 'racket-webview
|
|
"The racket-webview-qt executable is missing: ~a"
|
|
backend-program)))))))
|
|
|
|
(define (environment-set-string! environment name value)
|
|
(environment-variables-set! environment
|
|
(string->bytes/utf-8 name)
|
|
(string->bytes/utf-8 value)))
|
|
|
|
(define (make-backend-environment)
|
|
(define environment
|
|
(environment-variables-copy (current-environment-variables)))
|
|
(define directory-string (path->string backend-directory))
|
|
|
|
(environment-set-string! environment "QT_PLUGIN_PATH" directory-string)
|
|
(environment-set-string! environment
|
|
"QTWEBENGINEPROCESS_PATH"
|
|
(path->string
|
|
(build-path backend-directory webengine-process)))
|
|
(environment-set-string! environment
|
|
"QTWEBENGINE_RESOURCES_PATH"
|
|
(path->string
|
|
(build-path backend-directory "resources")))
|
|
(environment-set-string! environment
|
|
"QTWEBENGINE_LOCALES_PATH"
|
|
(path->string
|
|
(build-path backend-directory
|
|
"translations"
|
|
"qtwebengine_locales")))
|
|
|
|
(when (eq? os 'linux)
|
|
(let* ((old-library-path
|
|
(environment-variables-ref environment #"LD_LIBRARY_PATH"))
|
|
(added-library-path
|
|
(string-append
|
|
directory-string
|
|
":"
|
|
(path->string (build-path backend-directory "platforms")))))
|
|
(environment-set-string! environment "QT_QPA_PLATFORM" "xcb")
|
|
(environment-set-string!
|
|
environment
|
|
"LD_LIBRARY_PATH"
|
|
(if old-library-path
|
|
(string-append added-library-path
|
|
":"
|
|
(bytes->string/utf-8 old-library-path))
|
|
added-library-path))))
|
|
|
|
environment)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Handles and event dispatch
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-struct rkt-wv
|
|
(win evt-queue callback [valid #:mutable] [close-callback #:mutable])
|
|
#:transparent)
|
|
|
|
(define rkt-wv-store (make-hash))
|
|
(define evt-cb-hash (make-hash))
|
|
|
|
(define state-lock (make-semaphore 1))
|
|
|
|
(define (with-state-lock thunk)
|
|
(call-with-semaphore state-lock thunk))
|
|
|
|
(define event-channel (make-async-channel))
|
|
|
|
(define event-thread
|
|
(thread
|
|
(lambda ()
|
|
(let loop ()
|
|
;; Capture the callback while reading stdout. In particular, a
|
|
;; "closed" event is written before the corresponding close result;
|
|
;; the handle may already have been removed by the time this thread runs.
|
|
(define event (async-channel-get event-channel))
|
|
(define callback (vector-ref event 0))
|
|
(define data (vector-ref event 1))
|
|
(when callback
|
|
(with-handlers ((exn:fail?
|
|
(lambda (exception)
|
|
(err-webview
|
|
"Exception in webview event callback: ~a"
|
|
(exn-message exception)))))
|
|
(callback data)))
|
|
(loop)))))
|
|
|
|
(define (invalidate-all-handles!)
|
|
(with-state-lock
|
|
(lambda ()
|
|
(for ([(wv handle) (in-hash rkt-wv-store)])
|
|
(set-rkt-wv-valid! handle #f))
|
|
(hash-clear! evt-cb-hash)
|
|
(hash-clear! rkt-wv-store))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Stdio transport
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define backend-process #f)
|
|
(define backend-in #f)
|
|
(define backend-out #f)
|
|
(define backend-error-in #f)
|
|
(define backend-reader-thread #f)
|
|
(define backend-error-thread #f)
|
|
(define backend-watcher-thread #f)
|
|
|
|
(define backend-failure #f)
|
|
(define backend-closing? #f)
|
|
(define backend-ready? #f)
|
|
(define backend-ready-status #f)
|
|
(define backend-ready-semaphore (make-semaphore 0))
|
|
|
|
(define startup-lock (make-semaphore 1))
|
|
(define write-lock (make-semaphore 1))
|
|
(define pending-lock (make-semaphore 1))
|
|
(define pending-responses (make-hash))
|
|
(define request-id 0)
|
|
(define function-calls 0)
|
|
(define event-count 0)
|
|
|
|
(define (make-backend-exception message)
|
|
(exn:fail message (current-continuation-marks)))
|
|
|
|
(define (with-pending-lock thunk)
|
|
(call-with-semaphore pending-lock thunk))
|
|
|
|
(define (fail-pending-requests! exception)
|
|
(define channels
|
|
(with-pending-lock
|
|
(lambda ()
|
|
(define result
|
|
(for/list ([(id channel) (in-hash pending-responses)])
|
|
channel))
|
|
(hash-clear! pending-responses)
|
|
result)))
|
|
(for-each (lambda (channel)
|
|
(async-channel-put channel exception))
|
|
channels))
|
|
|
|
(define (backend-active?)
|
|
(and backend-process
|
|
backend-in
|
|
backend-out
|
|
(not backend-failure)))
|
|
|
|
(define (backend-ended! message)
|
|
;; Preserve the first failure. Every pending and future command must see
|
|
;; the same terminal backend exception.
|
|
(define exception
|
|
(or backend-failure
|
|
(make-backend-exception message)))
|
|
|
|
(unless backend-ready?
|
|
(set! backend-ready-status exception)
|
|
(semaphore-post backend-ready-semaphore))
|
|
|
|
(unless backend-closing?
|
|
(unless backend-failure
|
|
(set! backend-failure exception)
|
|
(err-webview "racket-webview-qt backend stopped: ~a" message)
|
|
(invalidate-all-handles!)))
|
|
|
|
(fail-pending-requests! exception)
|
|
exception)
|
|
|
|
(define (dispatch-protocol-message message)
|
|
(unless (hash? message)
|
|
(error 'racket-webview "Backend emitted a non-object JSON value"))
|
|
|
|
(let ((type (hash-ref message 'type #f)))
|
|
(cond
|
|
((equal? type "ready")
|
|
(set! backend-ready-status (hash-ref message 'protocol #f))
|
|
(semaphore-post backend-ready-semaphore))
|
|
|
|
((equal? type "result")
|
|
(let* ((id (hash-ref message 'id #f))
|
|
(channel
|
|
(and id
|
|
(with-pending-lock
|
|
(lambda ()
|
|
(define result (hash-ref pending-responses id #f))
|
|
(when result
|
|
(hash-remove! pending-responses id))
|
|
result)))))
|
|
(if channel
|
|
(async-channel-put channel message)
|
|
(warn-webview "Result for unknown request id ~a" id))))
|
|
|
|
((equal? type "event")
|
|
(let* ((wv (hash-ref message 'wv -1))
|
|
(callback
|
|
(with-state-lock
|
|
(lambda ()
|
|
(hash-ref evt-cb-hash wv #f)))))
|
|
(set! event-count (add1 event-count))
|
|
(when callback
|
|
(async-channel-put event-channel
|
|
(vector callback
|
|
(hash-ref message 'data ""))))))
|
|
|
|
((equal? type "protocol-error")
|
|
(let* ((id (hash-ref message 'id #f))
|
|
(text (hash-ref message 'message "unknown error"))
|
|
(exception
|
|
(make-backend-exception
|
|
(format "Backend protocol error: ~a" text)))
|
|
(channel
|
|
(and id
|
|
(with-pending-lock
|
|
(lambda ()
|
|
(define result (hash-ref pending-responses id #f))
|
|
(when result
|
|
(hash-remove! pending-responses id))
|
|
result)))))
|
|
(if channel
|
|
(async-channel-put channel exception)
|
|
(err-webview "Backend protocol error: ~a" text))))
|
|
|
|
(else
|
|
(warn-webview "Unknown backend message type: ~a" type)))))
|
|
|
|
(define (start-protocol-reader!)
|
|
(set!
|
|
backend-reader-thread
|
|
(thread
|
|
(lambda ()
|
|
(with-handlers
|
|
((exn:fail?
|
|
(lambda (exception)
|
|
(backend-ended!
|
|
(format "cannot read backend stdout: ~a"
|
|
(exn-message exception))))))
|
|
(let loop ()
|
|
(define message (read-json backend-in))
|
|
(if (eof-object? message)
|
|
(backend-ended! "stdout was closed")
|
|
(begin
|
|
(dispatch-protocol-message message)
|
|
(loop)))))))))
|
|
|
|
(define (log-backend-line line)
|
|
(cond
|
|
((regexp-match? #rx"^ERROR[ ]*:" line)
|
|
(err-webview "qt: ~a" line))
|
|
((regexp-match? #rx"^WARNING[ ]*:" line)
|
|
(warn-webview "qt: ~a" line))
|
|
((regexp-match? #rx"^INFO[ ]*:" line)
|
|
(info-webview "qt: ~a" line))
|
|
((regexp-match? #rx"^DEBUG[ ]*:" line)
|
|
(dbg-webview "qt: ~a" line))
|
|
(else
|
|
(dbg-webview "qt: ~a" line))))
|
|
|
|
(define (start-error-forwarder!)
|
|
(set!
|
|
backend-error-thread
|
|
(thread
|
|
(lambda ()
|
|
(with-handlers
|
|
((exn:fail?
|
|
(lambda (exception)
|
|
(warn-webview "Cannot read backend stderr: ~a"
|
|
(exn-message exception)))))
|
|
(let loop ()
|
|
(define line (read-line backend-error-in 'any))
|
|
(unless (eof-object? line)
|
|
(log-backend-line line)
|
|
(loop))))))))
|
|
|
|
(define (start-process-watcher!)
|
|
(set!
|
|
backend-watcher-thread
|
|
(thread
|
|
(lambda ()
|
|
(with-handlers
|
|
((exn:fail?
|
|
(lambda (exception)
|
|
(backend-ended!
|
|
(format "cannot wait for backend process: ~a"
|
|
(exn-message exception))))))
|
|
(subprocess-wait backend-process)
|
|
(define status (subprocess-status backend-process))
|
|
(unless backend-closing?
|
|
(backend-ended!
|
|
(format "process exited with status ~a" status))))))))
|
|
|
|
(define (reset-backend-state!)
|
|
(set! backend-process #f)
|
|
(set! backend-in #f)
|
|
(set! backend-out #f)
|
|
(set! backend-error-in #f)
|
|
(set! backend-reader-thread #f)
|
|
(set! backend-error-thread #f)
|
|
(set! backend-watcher-thread #f)
|
|
(set! backend-failure #f)
|
|
(set! backend-closing? #f)
|
|
(set! backend-ready? #f)
|
|
(set! backend-ready-status #f))
|
|
|
|
(define (stop-failed-backend-start!)
|
|
(when backend-out
|
|
(with-handlers ((exn:fail? void))
|
|
(close-output-port backend-out)))
|
|
(when backend-process
|
|
(with-handlers ((exn:fail? void))
|
|
(subprocess-kill backend-process #t))
|
|
(with-handlers ((exn:fail? void))
|
|
(subprocess-wait backend-process)))
|
|
(when backend-reader-thread
|
|
(with-handlers ((exn:fail? void))
|
|
(thread-wait backend-reader-thread)))
|
|
(when backend-error-thread
|
|
(with-handlers ((exn:fail? void))
|
|
(thread-wait backend-error-thread)))
|
|
(when backend-watcher-thread
|
|
(with-handlers ((exn:fail? void))
|
|
(thread-wait backend-watcher-thread)))
|
|
(reset-backend-state!))
|
|
|
|
(define (start-backend!)
|
|
(ensure-backend-program!)
|
|
|
|
(set! backend-failure #f)
|
|
(set! backend-closing? #f)
|
|
(set! backend-ready? #f)
|
|
(set! backend-ready-status #f)
|
|
(set! backend-ready-semaphore (make-semaphore 0))
|
|
|
|
(let-values (((process stdout stdin stderr)
|
|
(parameterize ((current-environment-variables
|
|
(make-backend-environment))
|
|
(current-directory backend-directory))
|
|
(subprocess #f #f #f backend-program))))
|
|
(set! backend-process process)
|
|
(set! backend-in stdout)
|
|
(set! backend-out stdin)
|
|
(set! backend-error-in stderr)
|
|
|
|
(start-error-forwarder!)
|
|
(start-protocol-reader!)
|
|
(start-process-watcher!)
|
|
|
|
(unless (sync/timeout 15 backend-ready-semaphore)
|
|
(stop-failed-backend-start!)
|
|
(error 'racket-webview
|
|
"The racket-webview-qt backend did not complete its stdio handshake"))
|
|
|
|
(when (exn:fail? backend-ready-status)
|
|
(let ((exception backend-ready-status))
|
|
(stop-failed-backend-start!)
|
|
(raise exception)))
|
|
|
|
(unless (equal? backend-ready-status stdio-protocol-version)
|
|
(let ((actual backend-ready-status))
|
|
(stop-failed-backend-start!)
|
|
(error 'racket-webview
|
|
"Unsupported backend stdio protocol ~a; expected ~a"
|
|
actual
|
|
stdio-protocol-version)))
|
|
|
|
(set! backend-ready? #t)))
|
|
|
|
(define (ensure-backend!)
|
|
(call-with-semaphore
|
|
startup-lock
|
|
(lambda ()
|
|
;; A backend failure is terminal for this transport instance. Do not
|
|
;; silently start a fresh process: callers with stale webview handles
|
|
;; must receive the original exception instead.
|
|
(when backend-failure
|
|
(raise backend-failure))
|
|
(unless (backend-active?)
|
|
(start-backend!)))))
|
|
|
|
(define (send-command command data)
|
|
(ensure-backend!)
|
|
|
|
(let ((response-channel (make-async-channel))
|
|
(id #f))
|
|
(call-with-semaphore
|
|
write-lock
|
|
(lambda ()
|
|
(set! request-id (add1 request-id))
|
|
(set! id request-id)
|
|
(set! function-calls (add1 function-calls))
|
|
|
|
(with-pending-lock
|
|
(lambda ()
|
|
(hash-set! pending-responses id response-channel)))
|
|
|
|
(with-handlers
|
|
((exn:fail?
|
|
(lambda (exception)
|
|
(define failure
|
|
(backend-ended!
|
|
(format "cannot write backend stdin: ~a"
|
|
(exn-message exception))))
|
|
(raise failure))))
|
|
(write-json (hasheq 'type "command"
|
|
'id id
|
|
'command command
|
|
'data data)
|
|
backend-out)
|
|
(newline backend-out)
|
|
(flush-output backend-out))))
|
|
|
|
(let ((response (async-channel-get response-channel)))
|
|
(when (exn:fail? response)
|
|
(raise response))
|
|
response)))
|
|
|
|
(define (command-integer-result command data)
|
|
(hash-ref (send-command command data) 'result 17))
|
|
|
|
(define (command-symbol-result command data)
|
|
(result-code->symbol (command-integer-result command data)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Public low-level API
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (rkt-webview-new-context boilerplate-js server-cert)
|
|
(command-integer-result
|
|
cmd-context-new
|
|
(hasheq 'boilerplate_js boilerplate-js
|
|
'has_pem_cert (and server-cert #t)
|
|
'pem_cert (or server-cert ""))))
|
|
|
|
(define (rkt-webview-create context parent evt-callback close-callback)
|
|
(define parent-win
|
|
(if parent
|
|
(rkt-wv-win parent)
|
|
0))
|
|
(define wv
|
|
(command-integer-result
|
|
cmd-create-wv
|
|
(hasheq 'context context
|
|
'parent parent-win)))
|
|
(define handle
|
|
(make-rkt-wv wv
|
|
(make-queue)
|
|
evt-callback
|
|
#t
|
|
close-callback))
|
|
(with-state-lock
|
|
(lambda ()
|
|
(hash-set! evt-cb-hash
|
|
wv
|
|
(lambda (event)
|
|
(evt-callback handle event)))
|
|
(hash-set! rkt-wv-store wv handle)))
|
|
handle)
|
|
|
|
(define (rkt-webview-close handle)
|
|
(when (rkt-wv-valid handle)
|
|
(with-handlers ((exn:fail?
|
|
(lambda (exception)
|
|
(warn-webview "Could not close backend handle ~a: ~a"
|
|
(rkt-wv-win handle)
|
|
(exn-message exception)))))
|
|
(command-integer-result
|
|
cmd-close-wv
|
|
(hasheq 'wv (rkt-wv-win handle))))
|
|
|
|
(set-rkt-wv-valid! handle #f)
|
|
(with-state-lock
|
|
(lambda ()
|
|
(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 level)
|
|
(command-integer-result
|
|
cmd-set-loglevel
|
|
(hasheq 'wv (loglevel->integer level)))
|
|
(void))
|
|
|
|
(define (rkt-webview-info)
|
|
(define open-windows
|
|
(command-integer-result cmd-info (hasheq)))
|
|
(list (list 'transport 'stdio)
|
|
(list 'shm-usage 0)
|
|
(list 'shm-freelist 0 0)
|
|
(list 'shm-alloc 0 0 0.0)
|
|
(list 'open-windows open-windows)
|
|
(list 'calls function-calls)
|
|
(list 'events event-count)
|
|
(list 'log-file "stderr")))
|
|
|
|
(define (rkt-webview-set-ou-token handle token)
|
|
(command-integer-result
|
|
cmd-set-ou-token
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'token token))
|
|
#t)
|
|
|
|
(define (rkt-webview-set-url! handle url)
|
|
(command-symbol-result
|
|
cmd-set-url
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'url url)))
|
|
|
|
(define (rkt-webview-set-html! handle html)
|
|
(command-symbol-result
|
|
cmd-set-html
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'html html)))
|
|
|
|
(define (rkt-webview-set-title! handle title)
|
|
(command-symbol-result
|
|
cmd-set-title
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'title title)))
|
|
|
|
(define (rkt-webview-set-icon! handle icon-file)
|
|
(command-symbol-result
|
|
cmd-set-icon
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'icon icon-file)))
|
|
|
|
(define (rkt-webview-run-js handle js)
|
|
(command-symbol-result
|
|
cmd-run-js
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'js js)))
|
|
|
|
(define (rkt-webview-call-js handle js)
|
|
(define response
|
|
(send-command
|
|
cmd-call-js
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'js js)))
|
|
(list (result-code->symbol (hash-ref response 'result 17))
|
|
(hash-ref response 'data "")))
|
|
|
|
(define (rkt-webview-resize handle width height)
|
|
(command-symbol-result
|
|
cmd-resize
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'w width
|
|
'h height)))
|
|
|
|
(define (rkt-webview-move handle x y)
|
|
(command-symbol-result
|
|
cmd-move
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'x x
|
|
'y y)))
|
|
|
|
(define (handle-command-symbol-result command handle)
|
|
(command-symbol-result command (hasheq 'wv (rkt-wv-win handle))))
|
|
|
|
(define (rkt-webview-show handle)
|
|
(handle-command-symbol-result cmd-show handle))
|
|
|
|
(define (rkt-webview-hide handle)
|
|
(handle-command-symbol-result cmd-hide handle))
|
|
|
|
(define (rkt-webview-show-normal handle)
|
|
(handle-command-symbol-result cmd-show-normal handle))
|
|
|
|
(define (rkt-webview-minimize handle)
|
|
(handle-command-symbol-result cmd-minimize handle))
|
|
|
|
(define (rkt-webview-maximize handle)
|
|
(handle-command-symbol-result cmd-maximize handle))
|
|
|
|
(define (rkt-webview-present handle)
|
|
(handle-command-symbol-result cmd-present handle))
|
|
|
|
(define (rkt-webview-window-state handle)
|
|
(window-state-code->symbol
|
|
(command-integer-result
|
|
cmd-window-state
|
|
(hasheq 'wv (rkt-wv-win handle)))))
|
|
|
|
(define (rkt-webview-open-devtools handle)
|
|
(handle-command-symbol-result cmd-open-devtools handle))
|
|
|
|
(define (rkt-webview-choose-dir handle title base-dir)
|
|
(command-symbol-result
|
|
cmd-choose-dir
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'title title
|
|
'base_dir base-dir)))
|
|
|
|
(define (rkt-webview-file-open handle title base-dir permitted-exts)
|
|
(command-symbol-result
|
|
cmd-file-open
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'title title
|
|
'base_dir base-dir
|
|
'permitted_exts permitted-exts)))
|
|
|
|
(define (rkt-webview-file-save handle title base-dir permitted-exts)
|
|
(command-symbol-result
|
|
cmd-file-save
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'title title
|
|
'base_dir base-dir
|
|
'permitted_exts permitted-exts)))
|
|
|
|
(define (rkt-webview-messagebox handle title message submessage type)
|
|
(command-symbol-result
|
|
cmd-msg-box
|
|
(hasheq 'wv (rkt-wv-win handle)
|
|
'title title
|
|
'message message
|
|
'submessage submessage
|
|
'type (messagetype->integer type))))
|
|
|
|
(define (rkt-webview-version)
|
|
(list (list 'webview-stdio-api 1 0 0)
|
|
(list 'racket-webview-qt 0 2 3)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Tray API
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (rkt-webview-tray-create icon-file tooltip evt-callback)
|
|
(define tray
|
|
(command-integer-result
|
|
cmd-create-tray
|
|
(hasheq 'icon icon-file
|
|
'tooltip tooltip)))
|
|
(define handle
|
|
(make-rkt-wv tray
|
|
(make-queue)
|
|
evt-callback
|
|
#t
|
|
(lambda () #t)))
|
|
(with-state-lock
|
|
(lambda ()
|
|
(hash-set! evt-cb-hash
|
|
tray
|
|
(lambda (event)
|
|
(evt-callback handle event)))
|
|
(hash-set! rkt-wv-store tray handle)))
|
|
handle)
|
|
|
|
(define (rkt-webview-tray-set-icon! tray icon-file)
|
|
(command-symbol-result
|
|
cmd-tray-set-icon
|
|
(hasheq 'wv (rkt-wv-win tray)
|
|
'icon icon-file)))
|
|
|
|
(define (rkt-webview-tray-set-tooltip! tray tooltip)
|
|
(command-symbol-result
|
|
cmd-tray-set-tooltip
|
|
(hasheq 'wv (rkt-wv-win tray)
|
|
'tooltip tooltip)))
|
|
|
|
(define (rkt-webview-tray-show-message tray title message)
|
|
(command-symbol-result
|
|
cmd-tray-show-message
|
|
(hasheq 'wv (rkt-wv-win tray)
|
|
'title title
|
|
'message message)))
|
|
|
|
(define (rkt-webview-tray-set-menu! tray menu)
|
|
(define menu-json
|
|
(cond
|
|
((wv-menu? menu)
|
|
(and (not (wv-menu-empty? menu))
|
|
(wv-menu->json menu)))
|
|
((not menu) #f)
|
|
(else
|
|
(error 'rkt-webview-tray-set-menu!
|
|
"expected a wv-menu or #f; got ~a"
|
|
menu))))
|
|
|
|
(if menu-json
|
|
(command-symbol-result
|
|
cmd-tray-set-menu
|
|
(hasheq 'wv (rkt-wv-win tray)
|
|
'menu_json menu-json))
|
|
(command-symbol-result
|
|
cmd-tray-clear-menu
|
|
(hasheq 'wv (rkt-wv-win tray)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Administration and cleanup
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (rkt-webview-valid? handle)
|
|
(and (rkt-wv-valid handle)
|
|
(not (= 0
|
|
(command-integer-result
|
|
cmd-handle-is-valid
|
|
(hasheq 'wv (rkt-wv-win handle)))))))
|
|
|
|
(define webview-exit-done #f)
|
|
|
|
(define (wait-for-backend-and-reset!)
|
|
(when backend-out
|
|
(with-handlers ((exn:fail? void))
|
|
(close-output-port backend-out)))
|
|
(when backend-process
|
|
(with-handlers ((exn:fail? void))
|
|
(subprocess-wait backend-process)))
|
|
(when backend-reader-thread
|
|
(with-handlers ((exn:fail? void))
|
|
(thread-wait backend-reader-thread)))
|
|
(when backend-error-thread
|
|
(with-handlers ((exn:fail? void))
|
|
(thread-wait backend-error-thread)))
|
|
(when backend-watcher-thread
|
|
(with-handlers ((exn:fail? void))
|
|
(thread-wait backend-watcher-thread)))
|
|
(reset-backend-state!))
|
|
|
|
(define (rkt-webview-exit . arguments)
|
|
(define close-windows
|
|
(if (null? arguments)
|
|
#t
|
|
(car arguments)))
|
|
(define message
|
|
(if (or (null? arguments)
|
|
(null? (cdr arguments)))
|
|
#f
|
|
(cadr arguments)))
|
|
|
|
(set! backend-closing? #t)
|
|
|
|
(when close-windows
|
|
(let ((handles
|
|
(with-state-lock
|
|
(lambda ()
|
|
(for/list ([(wv handle) (in-hash rkt-wv-store)])
|
|
handle)))))
|
|
(for-each rkt-webview-close handles)))
|
|
|
|
(when (backend-active?)
|
|
(with-handlers ((exn:fail?
|
|
(lambda (exception)
|
|
(warn-webview "Could not stop backend cleanly: ~a"
|
|
(exn-message exception)))))
|
|
(send-command cmd-quit (hasheq))))
|
|
|
|
(when backend-process
|
|
(wait-for-backend-and-reset!))
|
|
|
|
(invalidate-all-handles!)
|
|
(set! webview-exit-done #t)
|
|
(info-webview "webview-exit done")
|
|
|
|
(when message
|
|
(error message)))
|