hans/web-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Working on.

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

20
private/web-racket.rkt
View File

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

241
private/web-wire.rkt
View File

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

4
private/webui-wire-download.rkt
View File

@@ -14,9 +14,11 @@
ww-webui-wire ww-webui-wire
) )
;(define (current-release os)
(define (ww-webui-wire) (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") (define ww-current-win-release "https://github.com/hdijkema/web-wire/releases/download/0.1/web-wire-0.1-win64.zip")

50
private/webui-wire-ffi.rkt
View File

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

59
private/webui-wire-ipc.rkt
View File

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