Working on.

Signed-off-by: Hans Dijkema <hans@dijkewijk.nl>
This commit is contained in:
2025-10-27 10:40:01 +01:00
parent 694d6777e9
commit 799b003729
5 changed files with 262 additions and 112 deletions

View File

@@ -193,19 +193,15 @@
(super-new)
(begin
(displayln (format "win-id: ~a, id: ~a" (send this get-win-id) (send this get-id)))
(inp-set! val (ww-get-value (send this get-win-id)
(send this get-id)))
(displayln (format "got value '~a'" val))
(send this connect 'input (λ (data)
(ww-debug data)
(let ((js-evt (hash-ref data 'js-evt #f)))
(unless (eq? js-evt #f)
(when (hash-has-key? js-evt 'value)
(inp-set! val (hash-ref js-evt 'value)))))))
(displayln "connected")
(send (send this win) bind 'input (format "#~a" (send this get-id)))
(displayln "bind of input?")
)
))
@@ -392,7 +388,6 @@
(ww-debug (format "call to bind ~a ~a ~a" event selector forced-cl))
(let ((infos (ww-bind win-id event selector)))
(for-each (λ (info)
(displayln (format "info = ~a" info))
(let* ((id (car info))
(tag (cadr info))
(type (caddr info)))
@@ -548,18 +543,11 @@
(define/public (choose-dir caption base-dir)
(let ((r (ww-choose-dir win-id caption base-dir)))
(if (eq? (car r) #f)
(ww-debug (format "choose-dir: ~a" r))
(if (eq? r 'cmd-nok)
#f
(let ((m (regexp-match re-choose-dir (cdr r))))
(if (eq? m #f)
#f
(let ((dir (caddr m)))
(ww-from-string dir))
)
)
)
)
)
r)))
; Supers first
(super-new)

View File

@@ -9,7 +9,7 @@
"../utils/utils.rkt"
"css.rkt"
"menu.rkt"
;"webui-wire-ffi.rkt"
"webui-wire-ffi.rkt"
"webui-wire-ipc.rkt"
"webui-wire-download.rkt"
)
@@ -21,6 +21,8 @@
ww-debug
ww-error
ww-display-log
ww-tail-log
ww-set-log-lines!
ww-cmd
ww-cmd-nok?
@@ -113,21 +115,21 @@
;; web-wire handling (interaction with the library)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define _ww-debug #f)
(define _ww-debug #t)
(define (ww-set-debug yn) (set! _ww-debug yn))
(define (do-debug str . var)
(when _ww-debug
(if (null? var)
(displayln (format "Debug: ~a" str))
(displayln (format "Debug: ~a: ~a" (car var) str))
(process-log 'WW-DEBUG (format "~a" str))
(process-log 'WW-DEBUG (format "~a: ~a" (car var) str))
)))
(define (err str . var)
(if (null? var)
(displayln (format "Error: ~a" str))
(displayln (format "Error: ~a: ~a" var str))
(process-log 'WW-ERROR (format "~a" str))
(process-log 'WW-ERROR (format "~a: ~a" var str))
))
(define-syntax debug
@@ -155,7 +157,6 @@
))
(define re-kind #px"([A-Z]+)[(]([0-9]+)[)][:]")
;(define re-event #px"([^:]+)[:]([0-9]+)([:](.*))?")
(define re-js-event #px"^([^:]+)([:](.*))?")
(define re-js-result #px"([0-9]+)[:]([^:]+)[:](.*)")
(define re-js-handle #px"([^:]+)[:]([0-9]+)[:]([0-9]+)([:](.*))?")
@@ -171,6 +172,7 @@
[event-thread #:mutable]
[stop-thread #:mutable]
[reader-thread #:mutable]
[type #:mutable]
)
)
@@ -179,18 +181,27 @@
(define evt-sem (make-semaphore))
(define evt-fifo (make-queue))
(define log-fifo (make-queue))
(define log-fifo-max 100)
(define log-fifo-max 2500)
(define (ww-set-log-lines! n)
(set! log-fifo-max (if (< n 10) 10
(if (> n 10000) 10000 n)))
(ensure-fifo)
)
(define re-event #px"^([^:]+)([:]([^:]+))?")
(define (event-queuer evt)
(define (event-queuer-ipc evt)
(enqueue! evt-fifo evt)
(semaphore-post evt-sem))
(define (process-event h evt*)
(let* ((evt evt*) ;(bytes->string/utf-8 evt*))
(m (regexp-match re-event evt)))
(define (event-queuer-ffi evt)
(let ((evt* (bytes->string/utf-8 evt)))
(enqueue! evt-fifo evt*)
(semaphore-post evt-sem)))
(define (process-event h evt)
(let* ((m (regexp-match re-event evt)))
(ww-debug evt)
(let* ((e (string->symbol (string-downcase (list-ref m 1))))
(win-id (if (eq? (list-ref m 3) #f) #f (string->number (list-ref m 3))))
@@ -203,7 +214,6 @@
(if (eq? evt-handler #f)
(ww-error (format "no event handler to handle event ~a" evt))
(queue-callback (lambda () (evt-handler e payload))))
; (evt-handler e payload))
)
)
)
@@ -220,48 +230,136 @@
(f))))))
(define (process-log kind* msg*)
(define (ensure-fifo)
(if (> (queue-length log-fifo) log-fifo-max)
(begin
(dequeue! log-fifo)
(ensure-fifo))
(queue-length log-fifo)))
(let ((kind kind*) ;(bytes->string/utf-8 kind*))
(msg msg*)) ;(bytes->string/utf-8 msg*)))
(enqueue! log-fifo (cons kind msg))
(define (ensure-fifo)
(if (> (queue-length log-fifo) log-fifo-max)
(begin
(dequeue! log-fifo)
(ensure-fifo))
(queue-length log-fifo)))
(define tail-handler #f)
(define (put-in-fifo kind msg)
(enqueue! log-fifo (cons kind msg))
(when tail-handler
(tail-handler kind msg))
)
(define (process-log-ipc kind msg)
(put-in-fifo kind msg)
(ensure-fifo))
(define process-log process-log-ipc)
(define (process-log-ffi kind* msg*)
(let ((kind (bytes->string/utf-8 kind*))
(msg (bytes->string/utf-8 msg*)))
(put-in-fifo kind msg)
(ensure-fifo)))
(define (ww-display-log)
(for-each (λ (item)
(displayln (format "~a - ~a" (car item) (cdr item))))
(queue->list log-fifo)))
(define (ww-do-display item filter)
(let ((displ #f))
(when (eq? filter #f)
(set! displ #t))
(when (symbol? filter)
(set! displ (eq? (car item) filter)))
(when (regexp? filter)
(when (or (regexp-match filter (cdr item))
(regexp-match filter (symbol->string (car item))))
(set! displ #t)))
(when displ
(displayln (format "~a - ~a" (car item) (cdr item)))))
)
(define (ww-display-log . filter*)
(let ((filter (if (null? filter*) #f (car filter*))))
(when (string? filter)
(set! filter (pregexp (string-append "(?i:" filter ")"))))
(when (list? filter)
(set! filter (pregexp (string-append "(?i:(" (string-join filter "|") "))"))))
(for-each (λ (item)
(ww-do-display item filter))
(queue->list log-fifo)))
)
(define (ww-start . args)
(define (ww-tail-log . args)
(let ((last-n 3)
(filter #f)
(stop-tail #f)
)
(let ((f (λ ()
(let ((arg (if (null? args) #f (car args))))
(unless (null? args)
(when (boolean? arg)
(when (eq? arg #f)
(set! stop-tail #t)))
(when (number? arg)
(set! last-n (if (< arg 0) 0 arg)))
(when (or (symbol? arg) (regexp? arg) (string? arg) (list? arg))
(set! filter arg)))
(set! args (if (null? args) '() (cdr args)))))))
(f)(f))
(ww-debug (format "tail log: ~a ~a ~a" last-n filter stop-tail))
(if stop-tail
(set! tail-handler #f)
(let* ((l (queue->list log-fifo))
(len (length l)))
(let ((nl (take-right l (if (<= last-n len) last-n len))))
(when (string? filter)
(set! filter (pregexp (string-append "(?i:" filter ")"))))
(when (list? filter)
(set! filter (pregexp (string-append "(?i:(" (string-join filter "|") "))"))))
(for-each (λ (item)
(ww-do-display item filter))
nl))
(set! tail-handler (λ (kind msg)
(ww-do-display (cons kind msg) filter))))
)
)
)
(define (ww-start* type args)
(when (eq? ww-current-handle #f)
(let* ((h (make-web-rkt (webui-ipc event-queuer process-log)
#f
#f
#f))
(thrd (event-handler h)))
(set-web-rkt-event-thread! h thrd)
(set! ww-current-handle h)))
(let ((h (make-web-rkt (if (eq? type 'ipc)
(webui-ipc event-queuer-ipc process-log-ipc)
(let ((existing-h (webwire-current)))
(if (eq? existing-h #f)
(webwire-new)
existing-h)))
#f
#f
#f
type)))
(when (eq? type 'ffi)
(unless (eq? (webwire-status (web-rkt-handle h)) 'valid)
(error (format "Invalid handle, cannot start webui-wire ffi, reason: ~a"
(webwire-status->string (webwire-status (web-rkt-handle h)))))))
(let ((thrd (event-handler h)))
(when (eq? type 'ffi)
(webwire-handlers! (web-rkt-handle h) event-queuer-ffi process-log-ffi))
(set-web-rkt-event-thread! h thrd)
(set! ww-current-handle h))
))
(unless (null? args)
(ww-log-level (car args)))
ww-current-handle)
(define (ww-start . args)
(ww-start* 'ipc args))
(define (ww-stop)
(unless (eq? ww-current-handle #f)
(let ((thr (web-rkt-event-thread ww-current-handle)))
(kill-thread thr))
;; inform event handlers of destroying of windows.
(let ((keys (hash-keys windows-evt-handlers)))
(for-each (λ (win-id)
(let ((handler (hash-ref windows-evt-handlers win-id)))
(handler 'destroyed #f)))
keys))
((web-rkt-handle ww-current-handle) "exit")
(ww-cmd "exit")
(let ((thr (web-rkt-event-thread ww-current-handle)))
(kill-thread thr))
(when (eq? (web-rkt-type ww-current-handle) 'ffi)
(webwire-destroy (web-rkt-handle ww-current-handle)))
(set! ww-current-handle #f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -328,7 +426,11 @@
(begin
(ww-stop)
#t)
(let ((result ((web-rkt-handle ww-current-handle) cmd)))
(let* ((type (web-rkt-type ww-current-handle))
(result (if (eq? type 'ipc)
((web-rkt-handle ww-current-handle) cmd)
(webwire-command (web-rkt-handle ww-current-handle) cmd)))
)
(let ((r (convert-result result)))
(check-nok cmd r)
r))))
@@ -877,26 +979,49 @@
-> symbol)
;; Files and directories
(define (ww-file-open win-id title dir file-filters)
(let ((cmd (format "file-open ~a ~a ~a ~a" win-id
(as-string title)
(as-string dir)
(as-string file-filters))))
(ww-cmd cmd)))
;(define (ww-file-open win-id title dir file-filters)
; (let ((cmd (format "file-open ~a ~a ~a ~a" win-id
; (as-string title)
; (as-string dir)
; (as-string file-filters))))
; (ww-cmd cmd)))
(define (ww-file-save win-id title dir file-filters overwrite)
(let ((cmd (format "file-save ~a ~a ~a ~a ~a" win-id
(as-string title)
(as-string dir)
(as-string file-filters)
(if overwrite 1 0))))
(ww-cmd cmd)))
(def-cmd ww-file-open
file-open ((win-id ww-win?)
(caption string?)
(dir string?)
(file-filters string?)) ()
-> string)
(define (ww-choose-dir win-id title dir)
(let ((cmd (format "choose-dir ~a ~a ~a" win-id
(as-string title)
(as-string dir))))
(ww-cmd cmd)))
(def-cmd ww-file-save
file-save ((win-id ww-win?)
(caption string?)
(dir string?)
(file-filters string?)
(overwrite boolean?)
) ()
-> string)
;(define (ww-file-save win-id title dir file-filters overwrite)
; (let ((cmd (format "file-save ~a ~a ~a ~a ~a" win-id
; (as-string title)
; (as-string dir)
; (as-string file-filters)
; (if overwrite 1 0))))
; (ww-cmd cmd)))
(def-cmd ww-choose-dir
choose-dir ((win-id ww-win?)
(caption string?)
(dir string?)
) ()
-> string)
;(define (ww-choose-dir win-id title dir)
; (let ((cmd (format "choose-dir ~a ~a ~a" win-id
; (as-string title)
; (as-string dir))))
; (ww-cmd cmd)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Finalizing stuff

View File

@@ -14,9 +14,11 @@
ww-webui-wire
)
;(define (current-release os)
(define (ww-webui-wire)
"/home/hans/src/racket/webui-wire/build/Debug/webui-wire"
(list "/home/hans/src/racket/webui-wire/build/Release/webui-wire")
;(list "/usr/bin/flatpak" "run" "nl.dijkewijk.webui-wire")
)
(define ww-current-win-release "https://github.com/hdijkema/web-wire/releases/download/0.1/web-wire-0.1-win64.zip")

View File

@@ -73,21 +73,26 @@
(will-register webwire-will
handle (λ (handle)
(webwire-destroy handle))))
(start-gui-processing)
handle))
#:c-id webwire_new)
(define-libwebui-wire webwire-current
(_fun -> (handle : _webui-handle/null)
-> (begin
(unless (eq? handle #f)
(will-register webwire-will
handle (λ (handle)
(webwire-destroy handle))))
(webwire-destroy handle)))
(start-gui-processing)
)
handle))
#:c-id webwire_current)
(define-libwebui-wire webwire-destroy
(_fun _webui-handle/null -> _void)
(_fun _webui-handle/null -> _void
-> (stop-gui-processing))
#:c-id webwire_destroy)
(define-libwebui-wire webwire-command
@@ -149,7 +154,7 @@
#:c-id webwire_status_string)
(define-libwebui-wire webwire-process-gui
(_fun _webui-handle/null -> _void)
(_fun _webui-handle/null -> _bool)
#:c-id webwire_process_gui)
@@ -263,13 +268,32 @@
; Make sure GUI Events are processed (e.g. for linux - gtk main loop)
(void (thread (λ ()
(let loop ()
(begin
(sleep 0.05)
(webwire-process-gui #f)
;(displayln 'process-gui-ok)
(loop)))
)
)
)
(define gui-processing-thread #f)
(define gui-processing-go-on #f)
(define (start-gui-processing)
(when (eq? gui-processing-thread #f)
(set! gui-processing-go-on #t)
(set! gui-processing-thread (thread (λ ()
(begin
(displayln "gui processing starts")
(letrec ((loop (λ ()
(sleep 0.05)
(let ((processed (webwire-process-gui #f)))
(when (or gui-processing-go-on processed)
(loop))))))
(loop))
(displayln "gui processing stops")
(set! gui-processing-thread #f)))))
)
)
(define (stop-gui-processing)
(void (thread (λ ()
(display "waiting 5 seconds")
(sleep 5)
(displayln "stopping gui processing")
(set! gui-processing-go-on #f)))))

View File

@@ -1,11 +1,19 @@
(module webui-wire-ipc racket/base
(require "webui-wire-download.rkt")
(require "webui-wire-download.rkt"
racket/string
)
(provide webui-ipc)
(define re-kind #px"^([^:]+)[:]")
(define (is-int? str)
(let ((re-num #px"^[0-9]+$"))
(if (regexp-match re-num str)
#t
#f)))
(define (read-eol port)
(read-string 1 port))
@@ -19,25 +27,28 @@
(log-processor 'stderr-reader "webui-wire executable exited")
'process-ended)
(begin
(unless (and
(string? colon)
(string=? colon ":"))
(error "Unexpected input from webui-wire standard error"))
(let* ((length (string->number str-length))
(input (read-string length process-stderr))
(m (regexp-match re-kind input))
)
(read-eol process-stderr)
(if (eq? m #f)
(log-processor 'stderr-reader
(format "Unexpected: no kind: input = ~a" input))
(let ((kind (string->symbol (list-ref m 1)))
(line (substring input (string-length (car m))))
)
(if (eq? kind 'EVENT)
(event-queuer line)
(log-processor kind line))))
)
(if (and (string? colon) (string=? colon ":") (is-int? str-length))
; process line
(let* ((length (string->number str-length))
(input (read-string length process-stderr))
(m (regexp-match re-kind input))
)
(read-eol process-stderr)
(if (eq? m #f)
(log-processor 'stderr-reader
(format "Unexpected: no kind: input = ~a" input))
(let ((kind (string->symbol (list-ref m 1)))
(line (substring input (string-length (car m))))
)
(if (eq? kind 'EVENT)
(event-queuer line)
(log-processor kind line))))
)
; otherwise skip line
(let* ((line (read-line process-stderr))
(msg (string-trim (string-append str-length colon line))))
(log-processor 'stderr-reader msg))
)
(reader)
)
))
@@ -48,12 +59,12 @@
)
(define (webui-ipc event-queuer log-processor)
(let ((webui-wire-exe (ww-webui-wire)))
(displayln webui-wire-exe)
(let* ((webui-wire-exe (ww-webui-wire))
(proc-args (append (list #f #f #f) webui-wire-exe))
)
(call-with-values
(λ () (subprocess #f #f #f webui-wire-exe))
(λ () (apply subprocess proc-args))
(λ (pid process-stdout process-stdin process-stderr)
;(displayln (format "~a ~a ~a ~a" pid process-stdout process-stdin process-stderr))
(let ((reader-thrd (process-stderr-reader process-stderr event-queuer log-processor)))
(λ (cmd)
(displayln cmd process-stdin)