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

Separation of concerns.

Browse Source
This commit is contained in:
Hans Dijkema
2025-10-09 15:18:10 +02:00
parent 79d00df746
commit 74bcddfcdb
6 changed files with 356 additions and 94 deletions
Download Patch File Download Diff File Expand all files Collapse all files

45
private/web-racket-version.rkt Normal file
View File

@@ -0,0 +1,45 @@
(module web-racket-version racket/base
(require racket/string)
(provide ww-version
ww-version-major
ww-version-minor
ww-version-patch
ww-ffi-version
ww-ffi-version-major
ww-ffi-version-minor
ww-ffi-version-patch
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utils
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (mk-version a b c)
(string-join
(map number->string (list a b c))
"."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Web Wire Version
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ww-version-major 0)
(define ww-version-minor 1)
(define ww-version-patch 3)
(define ww-version (mk-version ww-version-major ww-version-minor ww-version-patch))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Web Wire FFI Version
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ww-ffi-version-major 0)
(define ww-ffi-version-minor 2)
(define ww-ffi-version-patch 1)
(define ww-ffi-version (mk-version ww-ffi-version-major ww-ffi-version-minor ww-ffi-version-patch))
)

1
private/web-racket.rkt
View File

@@ -9,7 +9,6 @@
(prefix-in g: gregor)
(prefix-in g: gregor/time)
gregor-utils
net/sendurl
)
(provide ww-element%

94
private/web-wire.rkt
View File

@@ -4,15 +4,13 @@
racket/file
racket/gui
racket/port
file/unzip
net/url
racket/port
data/queue
json
"../utils/utils.rkt"
"css.rkt"
"menu.rkt"
"webui-wire-ffi.rkt"
"webui-wire-download.rkt"
)
(provide ww-start
@@ -85,96 +83,6 @@
ww-win-id
)
(define 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 (os)
(format "~a-~a" (system-type) (system-type 'word)))
(define (web-wire-exe)
(if (eq? (system-type) 'windows)
"web-wire.exe"
"web-wire"))
(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))
(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))
)
(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)))
(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")
)))
(define (download-if-needed release)
(let* ((os-dir (web-wire-dir))
(re #px"web[-]wire[-]([0-9.]+)[-]")
)
(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)
))
))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Some utils

106
private/webui-wire-download.rkt Normal file
View File

@@ -0,0 +1,106 @@
(module webui-wire-download racket/base
(require setup/dirs
net/sendurl
net/url
file/unzip
racket/file
)
(provide ww-current-win-release
ww-download-if-needed
)
(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 (os)
(format "~a-~a" (system-type) (system-type 'word)))
(define (web-wire-exe)
(if (eq? (system-type) 'windows)
"web-wire.exe"
"web-wire"))
(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))
(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))
)
(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)))
(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")
)))
(define (ww-download-if-needed release)
(let* ((os-dir (web-wire-dir))
(re #px"web[-]wire[-]([0-9.]+)[-]")
)
(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)
))
))))
)

111
private/webui-wire.rkt Normal file
View File

@@ -0,0 +1,111 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
ffi/unsafe/atomic
setup/dirs
"../utils/utils.rkt"
(prefix-in g: racket/gui)
)
(provide webwire_new
webwire_destroy
webwire_command
webwire_get
webwire_status
webwire_status_string
reader)
(define-ffi-definer define-libwebui-wire
(ffi-lib "c:/devel/racket/webui-wire/build/Debug/libwebui-wire.dll"
#:custodian (current-custodian)))
;(ffi-lib "libwebui-wire" '("3" "4" "5" #f)
; #:get-lib-dirs (lambda ()
; (cons (build-path ".") (get-lib-search-dirs)))
; #:fail (lambda ()
; (ffi-lib (get-lib-path "libwebui-wire.dll")))
; ))
(define _webui-handle _pointer)
(define _webui-get-result
(_enum '(null = 0
event
log
invalid-handle = 256
)))
(define _webui-handle-status
(_enum '(valid = 1
handle-destroyed
handle-needs-destroying
null-handle
existing-handle-destroy-this-one
handle-invalid-unexpected
)))
(define-libwebui-wire webwire_new
(_fun -> _webui-handle))
(define-libwebui-wire webwire_destroy
(_fun _webui-handle -> _void))
(define-libwebui-wire webwire_command
(_fun _webui-handle _string/utf-8 -> _string/utf-8))
(define-libwebui-wire webwire_get
(_fun _webui-handle
[evt : (_ptr o _string/utf-8)]
[kind : (_ptr o _string/utf-8)]
[msg : (_ptr o _string/utf-8)]
-> [ result : _webui-get-result ]
-> (list result evt kind msg)))
(define-libwebui-wire webwire_status
(_fun _webui-handle -> _webui-handle-status))
(define-libwebui-wire webwire_status_string
(_fun _webui-handle-status -> _string/utf-8))
(define (webwire-new evt-cb log-cb)
(parameterize ([g:current-eventspace (g:current-eventspace)])
(let ((evtcb (lambda (msg)
(g:queue-callback (lambda () (evt-cb msg)))))
(logcb (lambda (k m)
(g:queue-callback (lambda () (log-cb k m)))))
)
(webwire_new evtcb logcb))))
(define last-evt #f)
(define (evt msg)
(displayln msg)
(set! last-evt msg))
(define last-log #f)
(define (log k m)
(let ((msg (format "~a ~a" k m)))
(displayln msg)
(set! last-log msg)))
(define (reader h)
(let ((l (webwire_get h)))
(let ((result (car l)))
(unless (or (eq? result 'null) (eq? result 'invalid-handle))
(let* ((evt (cadr l))
(kind (caddr l))
(msg (cadddr l)))
(unless (eq? evt #f)
(displayln (format "EVENT:~a" evt)))
(unless (eq? kind #f)
(displayln (format "~a:~a" kind msg)))
(reader h)))
result)))

93
private/ww-time.rkt Normal file
View File

@@ -0,0 +1,93 @@
(module ww-time racket/base
(require "../utils/sprintf.rkt")
(define-struct time
(second minute hour time-zone-offset) #:transparent)
(define (time-for-time-zone-offset t time-zone-offset)
(let* ((tzo-t (time-time-zone-offset t))
(tzo-d time-zone-offset))
(
(define (time-for-date dt t)
(make-date (time-second t) (time-minute t) (time-hour t)
(date-day dt) (date-month dt) (date-year dt)
(date-week-day dt) (date-year-day dt)
(date-dst? dt) (date-time-zone-offset )))
(define (->time date_or_time)
(if (time? date_or_time)
date_or_time
(if (date? date_or_time)
(time-of-date date_or_time)
(error "data? or time? expected"))))
(define (time-of-date dt)
(make-time (date-second dt) (date-minute dt) (date-hour dt)))
(define (time=? time_or_date_1 time_or_date_2)
(let ((t1 (->time time_or_date_1))
(t2 (->time time_or_date_2)))
(and
(= (time-hour t1) (time-hour t2))
(= (time-minute t1) (time-minute t2))
(= (time-second t1) (time-second t2)))))
(define (time>? time_or_date_1 time_or_date_2)
(let ((t1 (->time time_or_date_1))
(t2 (->time time_or_date_2)))
(if (> (time-hour t1) (time-hour t2))
#t
(if (= (time-hour t1) (time-hour t2))
(if (> (time-minute t1) (time-minute t2))
#t
(if (= (time-minute t1) (time-minute t2))
(> (time-second t1) (time-second t2))
#f
)
)
#f)
)
)
)
(define (time>=? a b)
(or (time>? a b) (time=? a b)))
(define (time<? a b)
(not (time>=? a b)))
(define (time<=? a b)
(not (time>? a b)))
(define (current-time)
(->time (seconds->date (current-seconds))))
(define re-time #px"([0-9]{1,2})[:]([0-9]{1,2})([:]([0-9]{1,2})){0,1}")
(define (string->time str)
(let ((m (regexp-match re-time str)))
(when (eq? m #t)
(error "time not recognized, should be '~H:~M' or '~H:~M:~S'"))
(let* ((h* (list-ref m 1))
(m* (list-ref m 2))
(s* (list-ref m 4))
(h (string->number h*))
(m (string->number m*))
(s (if (eq? s* #f) 0 (string->number s*))))
(when (> h 23)
(error "hour > 23"))
(when (> m 59)
(error "minute > 59"))
(when (> s 59)
(error "second > 59"))
(make-time s m h))))
(define (time->string t . seconds)
(let ((do-seconds (if (null? seconds) #t (car seconds))))
(if (eq? do-seconds #t)
(sprintf "%02d:%02d:%02d" (time-hour t) (time-minute t) (time-second t))
(sprintf "$02d:%02d" (time-hour t) (time-minute t)))))
); end of module