#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)))