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

Add HTML examples.

Browse Source 
Merge branch 'main' of https://github.com/hdijkema/web-racket

# Conflicts:
#	private/webui-wire-download.rkt

Signed-off-by: Hans Dijkema <hans@dijkewijk.nl>
This commit is contained in:
Hans Dijkema
2025-11-12 15:35:03 +01:00
parent 7492defaab
commit 51c8ef5aa1
8 changed files with 451 additions and 204 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
private/web-racket-version.rkt
View File

@@ -6,10 +6,10 @@
ww-version-major
ww-version-minor
ww-version-patch
ww-ffi-version
ww-ffi-version-major
ww-ffi-version-minor
ww-ffi-version-patch
ww-wire-version
ww-wire-version-major
ww-wire-version-minor
ww-wire-version-patch
)
@@ -36,10 +36,10 @@
;; Web Wire FFI Version
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ww-ffi-version-major 0)
(define ww-ffi-version-minor 2)
(define ww-ffi-version-patch 1)
(define ww-wire-version-major 0)
(define ww-wire-version-minor 2)
(define ww-wire-version-patch 8)
(define ww-ffi-version (mk-version ww-ffi-version-major ww-ffi-version-minor ww-ffi-version-patch))
(define ww-wire-version (mk-version ww-wire-version-major ww-wire-version-minor ww-wire-version-patch))
)

103
private/web-racket.rkt
View File

@@ -5,16 +5,18 @@
"css.rkt"
"menu.rkt"
"../utils/sprintf.rkt"
"webui-wire-download.rkt"
html-printer
(prefix-in g: gregor)
(prefix-in g: gregor/time)
gregor-utils
net/sendurl
racket/path
)
(provide ww-element%
ww-input%
ww-window%
ww-webview%
ww-start
ww-stop
@@ -23,6 +25,11 @@
ww-error
(all-from-out "css.rkt")
(all-from-out "menu.rkt")
ww-set-custom-webui-wire-command!
ww-display-log
ww-tail-log
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -232,7 +239,6 @@
))
;;;; Time input
(define ww-input-time%
(class ww-input%
@@ -283,7 +289,12 @@
(super-new)
))
(define ww-window%
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Classes representing WebView Windows.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ww-webview%
(class object%
(init-field [profile 'default-profile]
@@ -455,11 +466,19 @@
(ww-set-icon win-id icn))
(define/public (set-html-file! file)
(ww-debug (format "set-html-file! ~a" file))
(set! html-file file)
(set! html-handle (ww-set-html win-id html-file))
(ww-debug (format "html file set to ~a" html-file))
)
(let* ((full-path (if (string? file)
(string->path file)
file))
(folder (path-only full-path))
(the-file (file-name-from-path full-path))
)
(ww-debug (format "set-html-file! ~a, ~a" folder the-file))
(set! html-file file)
(when folder
(ww-cwd folder))
(set! html-handle (ww-set-html win-id the-file))
(ww-debug (format "html file set to ~a" the-file))
))
(define/public (set-url url)
(send-url url))
@@ -578,8 +597,19 @@
(hash-set! windows-evt-handlers (ww-win-id win-id) event-handler)
(hash-set! windows (ww-win-id win-id) this)
(ww-move win-id x y)
(ww-resize win-id width height)
(when parent
(let* ((parent-width (send parent get-width))
(parent-height (send parent get-height))
(parent-x (send parent get-x))
(parent-y (send parent get-y))
)
(set! x (+ parent-x (/ (- parent-width width) 2)))
(set! y (+ parent-y (/ (- parent-height height) 2)))
)
)
(ww-move win-id x y)
(send this set-title! title)
@@ -601,57 +631,6 @@
(define (get-global-stylesheet)
(ww-get-stylesheet))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Testing stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define test-menu (menu (menu-item 'm-file "File"
#:submenu
(menu (menu-item 'm-open "Open File")
(menu-item 'm-close "Close File")
(menu-item 'm-quit "Quit" #:separator #t)))
(menu-item 'm-edit "Edit"
#:submenu
(menu (menu-item 'm-copy "Copy")
(menu-item 'm-cut "Cut")
(menu-item 'm-paste "Paste")
(menu-item 'm-prefs "Preferences" #:separator #t)
))))
(define test-dialog%
(class ww-window%
(super-new [html-file "../../web-wire/test/dialog.html"]
[width 400]
[height 300])
(define/override (html-loaded)
(super html-loaded)
(ww-debug "html-loaded for test-dialog%")
(let* ((btn (send this element 'ok-btn)))
(send btn connect 'click (λ (data)
(send this close)))))
))
(define test-window%
(class ww-window%
(super-new [html-file "../../web-wire/test/test1.html"])
(define/override (html-loaded)
(ww-debug "HTML LOADED")
(super html-loaded)
(let* ((btn (send this element 'app-button)))
(send btn connect 'click (λ (data)
(new test-dialog% [parent this]))))
(ww-debug "SETTING MENU")
(send this set-menu! test-menu)
(send this connect-menu! 'm-quit (λ () (send this close)))
)
(begin
)
)
)
); end of module

56
private/web-wire.rkt
View File

@@ -26,6 +26,8 @@
ww-cmd
ww-cmd-nok?
ww-cwd
ww-protocol
ww-log-level
ww-set-stylesheet
@@ -104,11 +106,20 @@
(string-replace s* "\\\"" "\"")))
(define (to-server-file html-file)
(let* ((path (build-path html-file))
(complete-p (path->complete-path path))
(a-file (format "~a" complete-p))
(the-file (string-replace a-file "\\" "/")))
the-file))
(let ((to-file (λ (p) (string-replace (format "~a" p) "\\" "/")))
(file-path (build-path (format "~a" html-file))))
(if (absolute-path? file-path)
(to-file file-path)
(let* ((cwd (ww-cwd))
(full-file (build-path cwd (format "~a" html-file))))
(if (file-exists? full-file)
(to-file html-file)
(to-file (path->complete-path (build-path html-file)))
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; web-wire handling (interaction with the library)
@@ -217,6 +228,8 @@
)
)
)
(define evt-hdlr 0)
(define (event-handler h)
(parameterize ([current-eventspace (current-eventspace)])
@@ -225,10 +238,17 @@
(letrec ((f (lambda ()
(semaphore-wait evt-sem)
(queue-callback
(lambda () (process-event h (dequeue! evt-fifo))))
(lambda ()
(letrec ((queue-loop (λ ()
(when (> (queue-length evt-fifo) 0)
(process-event h (dequeue! evt-fifo))
(queue-loop)))))
(queue-loop))))
(f))))
(f))))))
(f)))
)
)
)
(define (ensure-fifo)
(if (> (queue-length log-fifo) log-fifo-max)
@@ -314,6 +334,9 @@
(define (ww-start* type args)
(when (eq? ww-current-handle #f)
(set! evt-sem (make-semaphore))
(set! evt-fifo (make-queue))
(set! log-fifo (make-queue))
(let ((h (make-web-rkt (if (eq? type 'ipc)
(webui-ipc event-queuer-ipc process-log-ipc)
(error "ffi integration not implemented"))
@@ -451,7 +474,15 @@
r)))
(define (html-file-exists? f)
(file-exists? f))
(if (file-exists? f)
#t
(let* ((cwd (ww-cwd))
(full-file (build-path cwd f)))
(ww-debug (format "file-exists? '~a'" full-file))
(file-exists? full-file)
)
)
)
(define (html-or-file? v)
(if (file-exists? v)
@@ -515,15 +546,15 @@
((eq? type 'ww-win) (make-ww-win (string->number str)))
((eq? type 'void) 'void)
((eq? type 'css-style) (string->css-style str))
((eq? type 'path) (string->path str))
((eq? type 'path) (string->path (substring (substring str 0 (- (string-length str) 1)) 1)))
(else str)))
(define (check-cmd-type v vname type typename)
(let ((is-type (type v)))
(unless is-type
(error
(format "Expected ~a of type ~a"
vname typename)))
(format "Expected ~a of type ~a, got '~a'"
vname typename v)))
#t))
(define (convert-arg-to-cmd v vname type)
@@ -793,6 +824,7 @@
;; Set inner html of an Id of the HTML in the window
(def-cmd ww-set-inner-html
set-inner-html ((win-id ww-win?)
(element-id symbol-or-string?)
(html-of-file html-or-file?)) () -> void)

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

@@ -5,112 +5,151 @@
net/url
file/unzip
racket/file
"web-racket-version.rkt"
racket/system
)
(provide ww-set-custom-webui-wire-command!
ww-get-webui-wire-command
)
(provide ww-current-win-release
ww-download-if-needed
ww-set-web-wire-location!
ww-webui-wire
(define (ww-get-webui-wire-command)
(unless (webui-wire-exists?)
(error "webui-wire needs to be installed in order to use web-racket"))
(get-webui-wire-cmd))
(define user-webui-wire-command #f)
(define (ww-set-custom-webui-wire-command! cmd)
(set! user-webui-wire-command cmd)
user-webui-wire-command)
(define (get-webui-wire-cmd)
(if (eq? user-webui-wire-command #f)
(let ((os (system-type 'os*)))
(if (eq? os 'linux)
"flatpak run nl.dijkewijk.webui-wire"
(format "~a"
(build-path (webui-wire-dir) (if (eq? os 'windows)
"webui-wire.exe"
"webui-wire")))))
user-webui-wire-command))
(define (webui-wire-dir)
(let* ((cache-dir (find-system-path 'cache-dir))
(ww-dir (build-path cache-dir "webui-wire"))
)
(unless (directory-exists? ww-dir)
(make-directory ww-dir))
ww-dir))
;(define (current-release os)
(define (flatpak-ok? str)
(let* ((re #px"([0-9]+)[.]([0-9]+)[.]([0-9]+)$")
(m (regexp-match re str))
(v (if (eq? m #f)
0
(let ((l (map string->number (cdr m))))
(+ (* (car l) 10000) (* (cadr l) 100) (caddr l))))))
(>= 11000)))
(define (ww-webui-wire)
(list "C:/devel/racket/webui-wire/build/Release/webui-wire.exe")
;(list "/home/hans/src/racket/webui-wire/build/Release/webui-wire")
;(list "/usr/bin/flatpak" "run" "nl.dijkewijk.webui-wire")
;(list "/Users/hans/src/webui-wire/build/Release/webui-wire")
(define (webui-wire-exists?)
(let ((os (system-type 'os*)))
(if (eq? os 'linux)
(webui-wire-exists-linux?)
(error "Currently not implemented for other systems than Linux")
)
)
)
(define ww-current-win-release "https://github.com/hdijkema/web-wire/releases/download/0.1/web-wire-0.1-win64.zip")
(define user-web-wire-location #f)
(define (ww-set-web-wire-location! path-or-dir)
(set! user-web-wire-location (build-path path-or-dir))
user-web-wire-location)
(define (webui-wire-exists-linux?)
(let ((flatpak (call-with-values (lambda () (process "flatpak --version"))
(lambda (args)
(let ((out (car args)))
(read-line out))))))
(unless (string? flatpak)
(error "Please install flatpak to use web-racket"))
(unless (flatpak-ok? flatpak)
(error (format "Not the right flatpak version installed: ~a" flatpak)))
(let ((webui-wire (call-with-values (lambda () (process "flatpak list --user | grep webui-wire"))
(lambda (args)
(let ((out (car args)))
(read-line out))))))
(if (string? webui-wire)
(let ((webui-wire-version (call-with-values (lambda () (process "flatpak run nl.dijkewijk.webui-wire --version"))
(lambda (args)
(let ((out (car args))
(in (cadr args)))
(displayln "exit" in)
(flush-output in)
(read-line out))))))
(if (string=? webui-wire-version ww-wire-version)
#t
(begin
(system "flatpak uninstall --user --noninteractive --assumeyes nl.dijkewijk.webui-wire")
(download-webui-wire-linux)))
)
(download-webui-wire-linux)))
)
)
(define (os)
(format "~a-~a" (system-type) (system-type 'word)))
(define (web-wire-exe)
(if (eq? (system-type) 'windows)
"web-wire.exe"
"web-wire"))
(define (download-webui-wire-linux)
(let* ((download-link (current-webui-wire-link))
(filepath (do-download download-link "webui-wire.flatpak")))
(system (format "flatpak install --user --assumeyes --noninteractive \"~a\"" filepath))
#t
)
)
(define (web-wire-dir)
(if (eq? user-web-wire-location #f)
(let* ((cache-dir (find-system-path 'cache-dir))
(os-dir (build-path cache-dir (os)))
(web-wire-prg (build-path os-dir (web-wire-exe)))
)
(unless (file-exists? web-wire-prg)
(error "Web wire executable not found: '~a'" web-wire-prg))
os-dir)
(let ((web-wire-prg (build-path user-web-wire-location (web-wire-exe))))
(unless (file-exists? web-wire-prg)
(error "Web wire executable not found: '~a'" web-wire-prg))
user-web-wire-location)
))
(define (web-wire-prg)
(build-path (web-wire-dir) (web-wire-exe)))
(define (do-download-and-extract release version os-dir)
(let* ((url (string->url release))
(define (do-download link filename)
(let* ((url (string->url link))
(port-in (get-pure-port url #:redirections 10))
(release-file (build-path os-dir "release.zip"))
(port-out (open-output-file release-file #:exists 'replace))
(filepath (build-path (webui-wire-dir) filename))
(port-out (open-output-file filepath #:exists 'replace))
)
(letrec ((f (lambda (count next-c len)
(let ((bytes (read-bytes 16384 port-in)))
(if (eof-object? bytes)
count
(let ((read-len (bytes-length bytes)))
(when (> read-len 0)
(set! count (+ count read-len))
(when (> count next-c)
(display (format "~a..." count))
(set! next-c (+ count len)))
(write-bytes bytes port-out)
)
(f count next-c len)))))
))
(display "Downloading web-wire...")
(let ((count (f 0 0 10000000)))
(letrec ((downloader-func (λ (count next-c len)
(let ((bytes (read-bytes 16384 port-in)))
(if (eof-object? bytes)
count
(let ((read-len (bytes-length bytes)))
(when (> read-len 0)
(set! count (+ count read-len))
(when (> count next-c)
(display (format "~a..." count))
(set! next-c (+ count len)))
(write-bytes bytes port-out)
)
(downloader-func count next-c len)))))
))
(display (format "Downloading webui-wire (~a)..." link))
(let ((count (downloader-func 0 0 10000)))
(displayln (format "~a downloaded" count)))
(close-input-port port-in)
(close-output-port port-out)
(display "Unzipping...")
(unzip release-file
(make-filesystem-entry-reader #:dest os-dir
#:strip-count 1
#:exists 'replace)
)
(display "removing zip file...")
(delete-file release-file)
(displayln "done")
)))
filepath)))
(define (ww-download-if-needed release)
(let* ((os-dir (web-wire-dir))
(re #px"web[-]wire[-]([0-9.]+)[-]")
(define (current-webui-wire-link)
(let* ((os (system-type 'os*))
(arch (system-type 'arch))
)
(unless (directory-exists? os-dir)
(make-directory* os-dir))
(let ((m (regexp-match re release)))
(unless (eq? m #f)
(let* ((version-file (build-path os-dir "version"))
(version (cadr m))
(has-version #f))
(when (file-exists? version-file)
(let ((file-version (file->value version-file)))
(when (string=? file-version version)
(set! has-version #t))))
(unless has-version
(do-download-and-extract release version os-dir)
(write-to-file version version-file)
))
))))
(when (eq? os #f)
(error "Operating system not automatically supported by webui-wire, you can compile it yourself and use 'ww-set-custom-webui-wire-command!'"))
(let ((os-str (symbol->string os))
(arch-str (symbol->string arch))
(ext (if (eq? os 'linux)
".flatpak"
(if (eq? os 'win64)
".exe"
""))))
(string-append "https://github.com/hdijkema/webui-wire/releases/download/v"
ww-wire-version "/webui-wire-v" ww-wire-version
"-" os-str "-" arch-str ext)
)
)
)
)

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

@@ -2,6 +2,7 @@
(require "webui-wire-download.rkt"
racket/string
racket/system
)
(provide webui-ipc)
@@ -61,28 +62,32 @@
)
(define (webui-ipc event-queuer log-processor)
(let* ((webui-wire-exe (ww-webui-wire))
(proc-args (append (list #f #f #f) webui-wire-exe))
)
(let ((webui-wire-cmd (ww-get-webui-wire-command)))
(call-with-values
(λ () (apply subprocess proc-args))
(λ (pid process-stdout process-stdin process-stderr)
(let ((reader-thrd (process-stderr-reader process-stderr event-queuer log-processor)))
(λ (cmd)
(displayln cmd process-stdin)
(flush-output process-stdin)
(let* ((str-length (read-string 8 process-stdout))
(colon (read-string 1 process-stdout)))
;(displayln (format "len: ~a, str-length: ~a, colon: ~a" (string-length str-length) str-length colon))
(unless (and (string? colon)
(λ () (process webui-wire-cmd))
(λ (args)
(let ((process-stdout (car args))
(process-stdin (cadr args))
(pid (caddr args))
(process-stderr (cadddr args))
(signal-func (car (cddddr args)))
)
(let ((reader-thrd (process-stderr-reader process-stderr event-queuer log-processor)))
(λ (cmd)
(displayln cmd process-stdin)
(flush-output process-stdin)
(let* ((str-length (read-string 8 process-stdout))
(colon (read-string 1 process-stdout)))
;(displayln (format "len: ~a, str-length: ~a, colon: ~a" (string-length str-length) str-length colon))
(unless (and (string? colon)
(string=? colon ":"))
(error "Unexpected input from webui-wire executable"))
(let* ((length (string->number str-length))
(input (read-string length process-stdout))
)
(error "Unexpected input from webui-wire executable"))
(let* ((length (string->number str-length))
(input (read-string length process-stdout))
)
(read-eol process-stdout)
input)))))
))
input)))))
)))
)