diff --git a/private/web-racket.rkt b/private/web-racket.rkt index 3508154..bcbf1d8 100644 --- a/private/web-racket.rkt +++ b/private/web-racket.rkt @@ -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) diff --git a/private/web-wire.rkt b/private/web-wire.rkt index 3e9e223..868aac5 100644 --- a/private/web-wire.rkt +++ b/private/web-wire.rkt @@ -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 (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* ((evt evt*) ;(bytes->string/utf-8 evt*)) - (m (regexp-match re-event evt))) + (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 diff --git a/private/webui-wire-download.rkt b/private/webui-wire-download.rkt index ae316ad..09312bd 100644 --- a/private/webui-wire-download.rkt +++ b/private/webui-wire-download.rkt @@ -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") diff --git a/private/webui-wire-ffi.rkt b/private/webui-wire-ffi.rkt index 6c08b8e..fb49f49 100644 --- a/private/webui-wire-ffi.rkt +++ b/private/webui-wire-ffi.rkt @@ -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))))) + + \ No newline at end of file diff --git a/private/webui-wire-ipc.rkt b/private/webui-wire-ipc.rkt index b2ca56b..1b86c19 100644 --- a/private/webui-wire-ipc.rkt +++ b/private/webui-wire-ipc.rkt @@ -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)