836 lines
28 KiB
Racket
836 lines
28 KiB
Racket
#lang racket/base
|
|
|
|
(require "racket-webview-qt.rkt"
|
|
"utils.rkt"
|
|
"mimetypes.rkt"
|
|
racket/async-channel
|
|
web-server/http
|
|
web-server/servlet-dispatch
|
|
web-server/web-server
|
|
web-server/servlet-env
|
|
(prefix-in c: net/cookies)
|
|
net/url
|
|
racket/runtime-path
|
|
racket/file
|
|
racket/string
|
|
racket/path
|
|
racket/port
|
|
racket/contract
|
|
xml
|
|
xml/xexpr
|
|
json
|
|
(prefix-in g: gregor)
|
|
(prefix-in g: gregor/time)
|
|
gregor-utils
|
|
lru-cache
|
|
racket-self-signed-cert
|
|
)
|
|
|
|
(provide webview-create
|
|
webview-devtools
|
|
webview-close
|
|
|
|
webview-run-js
|
|
webview-call-js
|
|
webview-call-js-result?
|
|
|
|
webview-move
|
|
webview-resize
|
|
webview-show
|
|
webview-hide
|
|
webview-show-normal
|
|
webview-maximize
|
|
webview-minimize
|
|
webview-window-state
|
|
webview-set-title!
|
|
|
|
webview-choose-dir
|
|
webview-file-open
|
|
webview-file-save
|
|
wv-permitted-exts
|
|
|
|
make-wv-permitted-exts
|
|
wv-permitted-exts-name
|
|
wv-permitted-exts-exts
|
|
set-wv-permitted-exts-exts!
|
|
set-wv-permitted-exts-name!
|
|
wv-permitted-exts?
|
|
wv-permitted-exts-exts?
|
|
wv-list-of-permitted-exts?
|
|
|
|
webview-bind!
|
|
|
|
webview-set-url!
|
|
webview-navigate!
|
|
webview-set-html!
|
|
webview-base-url
|
|
|
|
webview-set-innerHTML!
|
|
|
|
webview-set-value!
|
|
|
|
webview-value
|
|
webview-value/bool
|
|
webview-value/symbol
|
|
webview-value/number
|
|
webview-value/date
|
|
webview-value/time
|
|
webview-value/datetime
|
|
|
|
webview-add-class!
|
|
webview-remove-class!
|
|
webview-set-style!
|
|
webview-unset-style!
|
|
|
|
webview-set-attr!
|
|
webview-attr
|
|
webview-attr/bool
|
|
webview-attr/symbol
|
|
webview-attr/number
|
|
webview-attr/date
|
|
webview-attr/time
|
|
webview-attr/datetime
|
|
|
|
;webview-del-attr!
|
|
|
|
webview-standard-file-getter
|
|
|
|
test
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Web server
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-runtime-path js-path "../js")
|
|
|
|
(define (default-boilerplate-js)
|
|
(let ((file (build-path js-path "boilerplate.js")))
|
|
(file->string file)))
|
|
|
|
(define-struct wv
|
|
([handle #:mutable]
|
|
[port #:mutable]
|
|
[window-nr #:mutable]
|
|
[file-getter #:mutable]
|
|
[boilerplate-js #:mutable]
|
|
[webserver-thread #:mutable]
|
|
[base-url #:mutable]
|
|
[request-count #:mutable]
|
|
[sec-token-cache #:mutable]
|
|
[cert-ou-token #:mutable]
|
|
[context #:mutable]
|
|
)
|
|
#:transparent)
|
|
|
|
(define (process-html wv-handle path out)
|
|
(let ((html (file->string path))
|
|
(boilerplate-js ((wv-boilerplate-js wv-handle))))
|
|
(set! html (string-replace html "<head>"
|
|
(string-append "<head>" "\n"
|
|
"<script>" "\n"
|
|
boilerplate-js "\n"
|
|
"</script>" "\n")))
|
|
(display html out)))
|
|
|
|
(define (process-file wv-handle ext path out)
|
|
(let ((content (file->bytes path)))
|
|
(display content out)))
|
|
|
|
(define (make-security-token)
|
|
(letrec ((f (λ (n)
|
|
(if (= 0 n)
|
|
""
|
|
(string-append
|
|
(string (integer->char (+ 97 (random 26))))
|
|
(f (- n 1)))))))
|
|
(string->symbol (f 20))))
|
|
|
|
(define (get-security-token req)
|
|
(let* ((headers (request-headers/raw req))
|
|
(cookie-header (findf (λ (h)
|
|
(eq? (string->symbol
|
|
(format "~a" (header-field h)))
|
|
'Cookie))
|
|
headers)))
|
|
(if (eq? cookie-header #f)
|
|
#f
|
|
(let ((cookies (c:cookie-header->alist (header-value cookie-header))))
|
|
(displayln (format "Cookies: ~a" cookies))
|
|
(let ((sec-token (findf (λ (c)
|
|
(eq? (string->symbol
|
|
(format "~a" (car c)))
|
|
'rkt-webview-token))
|
|
cookies)))
|
|
(if (eq? sec-token #f)
|
|
#f
|
|
(string->symbol (format "~a" (cdr sec-token)))))))))
|
|
|
|
(define (make-sec-header sec-cache)
|
|
(let ((tok (make-security-token)))
|
|
(lru-add! sec-cache tok)
|
|
(displayln (format "new sec-token: ~a" tok))
|
|
(make-header #"Set-Cookie"
|
|
(string->bytes/utf-8
|
|
(format "rkt-webview-token=~a" tok)))
|
|
)
|
|
)
|
|
|
|
(define (web-serve wv-handle req)
|
|
(let* ((path (url->string (request-uri req)))
|
|
(file-getter (wv-file-getter wv-handle))
|
|
(token (get-security-token req))
|
|
(sec-cache (wv-sec-token-cache wv-handle))
|
|
(cache-empty? (lru-empty? sec-cache))
|
|
(token-in-cache? (not (or (eq? token #f)
|
|
(eq? (lru-has? sec-cache token) #f))))
|
|
)
|
|
(if (and (eq? token-in-cache? #f) (not cache-empty?))
|
|
(response/output
|
|
#:code 401
|
|
(λ (out)
|
|
#t))
|
|
(let* ((file-to-serve (build-path (file-getter path)))
|
|
(ext-bytes (path-get-extension file-to-serve))
|
|
(ext (if (eq? ext-bytes #f) #f
|
|
(string->symbol
|
|
(string-downcase
|
|
(substring (bytes->string/utf-8 ext-bytes) 1)))))
|
|
)
|
|
(if (file-exists? file-to-serve)
|
|
(response/output
|
|
#:mime-type (string->bytes/utf-8 (mimetype-for-ext ext))
|
|
#:headers (list (make-sec-header sec-cache))
|
|
(λ (out)
|
|
(if (or (eq? ext 'html) (eq? ext 'htm))
|
|
(process-html wv-handle file-to-serve out)
|
|
(process-file wv-handle ext file-to-serve out))
|
|
))
|
|
(response/output
|
|
#:code 404
|
|
#:headers (list (make-sec-header sec-cache))
|
|
(λ (out)
|
|
(displayln (format "~a not found" path) out)))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (start-web-server h channel cert)
|
|
(if (eq? cert #f)
|
|
(thread (λ ()
|
|
(serve
|
|
#:dispatch (dispatch/servlet
|
|
(λ (req) (web-serve h req)))
|
|
#:listen-ip "127.0.0.1"
|
|
#:port 0
|
|
#:confirmation-channel channel
|
|
)
|
|
)
|
|
)
|
|
(let* ((cert-path (let ((p (build-path (find-system-path 'pref-dir) "racket-webview" (wv-context h))))
|
|
(make-directory* p)
|
|
p))
|
|
(window-nr (wv-window-nr h))
|
|
(f1 (build-path cert-path (format "self-signed-~a.cert" window-nr)))
|
|
(f2 (build-path cert-path (format "self-signed-~a.key" window-nr)))
|
|
(fh1 (open-output-file f1 #:exists 'replace #:permissions #o600))
|
|
(fh2 (open-output-file f2 #:exists 'replace #:permissions #o600)))
|
|
(display (certificate cert) fh1)
|
|
(display (private-key cert) fh2)
|
|
(close-output-port fh1)
|
|
(close-output-port fh2)
|
|
(thread (λ ()
|
|
(serve
|
|
#:dispatch (dispatch/servlet
|
|
(λ (req) (web-serve h req)))
|
|
#:dispatch-server-connect@ (make-ssl-connect@ f1 f2)
|
|
#:listen-ip "127.0.0.1"
|
|
#:port 0
|
|
#:confirmation-channel channel
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (remove-cert-files h)
|
|
(let* ((cert-path (build-path (find-system-path 'pref-dir)
|
|
"racket-webview"
|
|
(wv-context h)))
|
|
(window-nr (wv-window-nr h))
|
|
(f1 (build-path cert-path (format "self-signed-~a.cert" window-nr)))
|
|
(f2 (build-path cert-path (format "self-signed-~a.key" window-nr)))
|
|
)
|
|
(delete-file f1)
|
|
(delete-file f2)
|
|
)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Utilities
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (util-parse-event evt)
|
|
(let ((wv-d0 (with-input-from-string evt read-json)))
|
|
wv-d0))
|
|
|
|
(define (webview-call-js-result? x)
|
|
(if (and (list? x) (= (length x) 2))
|
|
(and (symbol? (car x))
|
|
(string? (cadr x)))
|
|
#f))
|
|
|
|
|
|
(define-syntax with-id
|
|
(syntax-rules ()
|
|
((_ id el
|
|
(code ...))
|
|
(string-append (format "{ let ~a = document.getElementById('~a');\n" 'el id)
|
|
(format code ...)
|
|
"\n}")
|
|
)
|
|
((_ id el
|
|
(code ...) -> retval)
|
|
(string-append (format "{ let ~a = document.getElementById('~a');\n" 'el id)
|
|
(format code ...)
|
|
(format "return ~a;\n" retval)
|
|
"}"))
|
|
((_ id el -> retval)
|
|
(string-append (format "{ let ~a = document.getElementById('~a');\n" 'el id)
|
|
(format "return ~a;\n" retval)
|
|
"}"))
|
|
)
|
|
)
|
|
|
|
(define-syntax with-selector
|
|
(syntax-rules ()
|
|
((_ selector func)
|
|
(format "return window.rkt_with_selector('~a', ~a)"
|
|
(esc-quote selector)
|
|
func))))
|
|
|
|
(define (make-exts-filter list-of-pe)
|
|
(define (mef pe)
|
|
(format "~a ~a"
|
|
(wv-permitted-exts-name pe)
|
|
(map (λ (e) (format "*.~a" e)) (wv-permitted-exts-exts pe))))
|
|
(string-join (map mef (if (list? list-of-pe) list-of-pe (list list-of-pe))) ";;"))
|
|
|
|
(define (filter->exts str)
|
|
(let ((re #px"^([^ ]+)\\s+[(]([^)]+)[)]"))
|
|
(let ((m (regexp-match re str)))
|
|
(cond ((eq? m #f)
|
|
#f)
|
|
(else (let* ((re1 #px"\\s+")
|
|
(re2 #px"[*][.](.*)")
|
|
(exts (regexp-split re1 (caddr m))))
|
|
(make-wv-permitted-exts (cadr m)
|
|
(map (λ (e)
|
|
(let ((m (regexp-match re2 e)))
|
|
(string->symbol (cadr m))))
|
|
exts))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Data structures
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-struct wv-permitted-exts
|
|
((name #:mutable) (exts #:mutable))
|
|
#:transparent
|
|
)
|
|
|
|
(define (wv-permitted-exts-exts? e)
|
|
(list-of? symbol? e))
|
|
|
|
(define (wv-permitted-exts-name? e)
|
|
(string? e))
|
|
|
|
(define wv-pm-exts? wv-permitted-exts?)
|
|
|
|
(set! wv-permitted-exts? (λ (e)
|
|
(and (wv-pm-exts? e)
|
|
(wv-permitted-exts-exts? (wv-permitted-exts-exts e))
|
|
(wv-permitted-exts-name? (wv-permitted-exts-name e))
|
|
)))
|
|
|
|
(define (wv-list-of-permitted-exts? l)
|
|
(list-of? (λ (e) (and
|
|
(wv-permitted-exts? e)
|
|
(wv-permitted-exts-exts? (wv-permitted-exts-exts e))))
|
|
l))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Webview functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define/contract (webview-create context file-getter event-callback
|
|
#:boilerplate-js [bj (λ () (default-boilerplate-js))]
|
|
#:parent [p #f])
|
|
(->* ((or/c symbol? string?) procedure? procedure?)
|
|
(#:boilerplate-js procedure? #:parent (or/c wv? #f))
|
|
wv?)
|
|
(let* ((h (make-wv #f 0 -1 file-getter bj #f #f 0 (make-lru 250 #:cmp eq?)
|
|
(symbol->string (make-security-token)) (symbol->string context)))
|
|
(cert (generate-self-signed-cert 2048 365 '("127.0.0.1" "localhost")
|
|
"NL" "Dijkema"
|
|
#:ou (wv-cert-ou-token h)))
|
|
(event-processor (λ (wv evt)
|
|
(event-callback h (util-parse-event evt))))
|
|
(close-callback (λ ()
|
|
(remove-cert-files h)))
|
|
(ph (if (wv? p) (wv-handle p) #f))
|
|
(wv (let ((internal-handle (rkt-webview-create ph event-processor close-callback)))
|
|
(set-wv-handle! h internal-handle)
|
|
(set-wv-window-nr! h (rkt-wv-win internal-handle))
|
|
internal-handle))
|
|
(channel (make-async-channel))
|
|
(server (let ((s (start-web-server h channel cert)))
|
|
(sleep 1) ;;; TODO: Check if web server is up.
|
|
s))
|
|
(port-nr (let ((pn (async-channel-get channel)))
|
|
(set-wv-port! h pn)
|
|
pn))
|
|
(base-req (format "https://127.0.0.1:~a" (wv-port h)))
|
|
)
|
|
(set-wv-webserver-thread! h server)
|
|
(set-wv-base-url! h base-req)
|
|
(rkt-webview-set-ou-token (wv-handle h) (wv-cert-ou-token h))
|
|
(rkt-webview-set-url! (wv-handle h) base-req)
|
|
h)
|
|
)
|
|
|
|
(define/contract (webview-devtools wv)
|
|
(-> wv? symbol?)
|
|
(rkt-webview-open-devtools (wv-handle wv)))
|
|
|
|
(define/contract (webview-move wv x y)
|
|
(-> wv? number? number? symbol?)
|
|
(rkt-webview-move (wv-handle wv) x y))
|
|
|
|
(define/contract (webview-resize wv w h)
|
|
(-> wv? number? number? symbol?)
|
|
(rkt-webview-resize (wv-handle wv) w h))
|
|
|
|
(define/contract (webview-set-html! wv html)
|
|
(-> wv? (or/c string? xexpr?) symbol?)
|
|
(if (string? html)
|
|
(rkt-webview-set-html! (wv-handle wv) html)
|
|
(rkt-webview-set-html! (wv-handle wv) (xexpr->string html))
|
|
)
|
|
)
|
|
|
|
(define/contract (webview-set-url! wv url)
|
|
(-> wv? (or/c string? url?) symbol?)
|
|
(let ((u (if (string? url) (string->url url) url))
|
|
(bu (string->url (wv-base-url wv))))
|
|
(when (or (eq? (url-scheme u) #f) (eq? (url-host u) #f))
|
|
(set-url-host! u (url-host bu))
|
|
(set-url-port! u (url-port bu))
|
|
(set-url-scheme! u (url-scheme bu))
|
|
(set-url-path-absolute?! u #t)
|
|
)
|
|
(when (eq? (url-scheme u) #f)
|
|
(set-url-scheme! (url-scheme bu)))
|
|
(rkt-webview-set-url! (wv-handle wv) (url->string u))
|
|
)
|
|
)
|
|
|
|
(define/contract (webview-navigate! wv place)
|
|
(-> wv? string? symbol?)
|
|
(webview-run-js wv
|
|
(format "window.location = '~a';"
|
|
(esc-quote place))))
|
|
|
|
(define/contract (webview-base-url wv)
|
|
(-> wv? url?)
|
|
(string->url (wv-base-url wv)))
|
|
|
|
|
|
(define-syntax def-win-func
|
|
(syntax-rules ()
|
|
((_ name name-to-wrap)
|
|
(define/contract (name wv)
|
|
(-> wv? symbol?)
|
|
(name-to-wrap (wv-handle wv))))))
|
|
|
|
(def-win-func webview-show rkt-webview-show)
|
|
(def-win-func webview-hide rkt-webview-hide)
|
|
(def-win-func webview-maximize rkt-webview-maximize)
|
|
(def-win-func webview-minimize rkt-webview-minimize)
|
|
(def-win-func webview-show-normal rkt-webview-show-normal)
|
|
(def-win-func webview-present rkt-webview-present)
|
|
(def-win-func webview-window-state rkt-webview-window-state)
|
|
|
|
(define/contract (webview-choose-dir wv title base-dir)
|
|
(-> wv? string? (or/c path? string?) (or/c hash? boolean?))
|
|
(let ((bd (if (path? base-dir) (path->string base-dir) base-dir)))
|
|
(let ((res (rkt-webview-choose-dir (wv-handle wv) title bd)))
|
|
(if (eq? res #f)
|
|
#f
|
|
(cond ((eq? (car res) 'oke)
|
|
(let ((r (make-hash (hash->list (fromJson (cadr res))))))
|
|
(hash-set! r 'state (string->symbol (hash-ref r 'state)))
|
|
r))
|
|
(else #f))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (file-open-save wv title base-dir permitted-exts open-save-f)
|
|
(let* ((bd (if (path? base-dir) (path->string base-dir) base-dir))
|
|
(ext-filter (make-exts-filter permitted-exts)))
|
|
(let ((res (open-save-f (wv-handle wv) title bd ext-filter)))
|
|
(if (eq? res #f)
|
|
#f
|
|
(cond ((eq? (car res) 'oke)
|
|
(let* ((h (make-hash (hash->list (fromJson (cadr res))))))
|
|
(hash-set! h 'state (string->symbol (hash-ref h 'state)))
|
|
(hash-set! h 'used-filter (filter->exts (hash-ref h 'used-filter)))
|
|
h))
|
|
(else #f))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
(define/contract (webview-file-open wv title base-dir permitted-exts)
|
|
(-> wv? string? (or/c path? string?) (or/c wv-permitted-exts? wv-list-of-permitted-exts?)
|
|
(or/c hash? boolean?))
|
|
(file-open-save wv title base-dir permitted-exts rkt-webview-file-open))
|
|
|
|
(define/contract (webview-file-save wv title base-dir permitted-exts)
|
|
(-> wv? string? (or/c path? string?) (or/c wv-permitted-exts? wv-list-of-permitted-exts?)
|
|
(or/c hash? boolean?))
|
|
(file-open-save wv title base-dir permitted-exts rkt-webview-file-save))
|
|
|
|
|
|
|
|
(define/contract (webview-set-title! wv title)
|
|
(-> wv? string? symbol?)
|
|
(rkt-webview-set-title! (wv-handle wv) title))
|
|
|
|
(define/contract (webview-close wv)
|
|
(-> wv? symbol?)
|
|
(begin
|
|
(rkt-webview-close (wv-handle wv))
|
|
(kill-thread (wv-webserver-thread wv))
|
|
'oke))
|
|
|
|
(define/contract (webview-bind! wv selector event)
|
|
(-> wv? (or/c symbol? string?) symbol? list?)
|
|
(let ((sel (if (symbol? selector)
|
|
(format "#~a" selector)
|
|
selector))
|
|
(evt (format "~a" event)))
|
|
(let ((r (webview-call-js wv
|
|
(format "return window.rkt_bind_evt_ids(~a, '~a', '~a')"
|
|
(wv-window-nr wv) sel evt))))
|
|
(map (λ (el)
|
|
(list (string->symbol (car el)) (cadr el) (caddr el)))
|
|
r))))
|
|
|
|
(define/contract (webview-run-js wv js)
|
|
(-> wv? string? symbol?)
|
|
(rkt-webview-run-js (wv-handle wv) js))
|
|
|
|
(define (webview-standard-file-getter base-path
|
|
#:not-exist [on-not-exist (λ (file base-path path) path)]
|
|
)
|
|
(λ (file)
|
|
(let ((f (if (string=? file "/") "index.html" file)))
|
|
(when (string-prefix? f "/")
|
|
(set! f (substring f 1)))
|
|
(let ((p (build-path base-path f)))
|
|
(if (not (file-exists? p))
|
|
(on-not-exist file base-path p)
|
|
p)))))
|
|
|
|
|
|
(define (webview-call-js wv js)
|
|
(-> wv? string? (or/c string? list? boolean? hash?))
|
|
(let ((result (rkt-webview-call-js (wv-handle wv) js)))
|
|
(if (webview-call-js-result? result)
|
|
(if (eq? (car result) 'oke)
|
|
(hash-ref (fromJson (cadr result)) 'result #f)
|
|
(error
|
|
(format "Error calling javascript. Message: ~a"
|
|
(hash-ref (fromJson (cadr result)) 'exn result)))
|
|
)
|
|
(error
|
|
(format "Wrong result from webview-call-js: ~a" result))
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Functions on top of the basics
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define/contract (webview-set-innerHTML! wv id html)
|
|
(-> wv? symbol? (or/c string? xexpr?) symbol?)
|
|
(if (string? html)
|
|
(webview-run-js wv
|
|
(with-id id el
|
|
("el.innerHTML = '~a';" (esc-quote html))))
|
|
(webview-set-innerHTML! wv id (xexpr->string html))
|
|
)
|
|
)
|
|
|
|
(define/contract (webview-set-value! wv id val)
|
|
(-> wv? symbol? (or/c symbol? string? number? boolean? g:date? g:time? g:datetime?) symbol?)
|
|
(webview-run-js wv
|
|
(with-id id el
|
|
((string-append
|
|
"if (el.type == 'checkbox' || el.type == 'radio') {\n"
|
|
" el.checked = ~a;\n"
|
|
"} else {\n"
|
|
" el.value = '~a';\n"
|
|
"}")
|
|
(if (eq? val #f) "false" "true")
|
|
(cond
|
|
([(g:date? val)]
|
|
(date->string val))
|
|
([(g:time? val)]
|
|
(time->string val))
|
|
([(g:datetime? val)]
|
|
(datetime->string val))
|
|
(else
|
|
(esc-quote (format "~a" val))))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define/contract (webview-value wv id)
|
|
(-> wv? symbol? (or/c string? boolean?))
|
|
(let ((v (webview-call-js wv
|
|
(with-id id el
|
|
((string-append "let f = function() {\n"
|
|
" if (el.type == 'checkbox' || el.type == 'radio') {\n"
|
|
" return '' + el.checked;\n"
|
|
" } else {\n"
|
|
" return el.value;\n"
|
|
" }\n"
|
|
"};\n"))
|
|
-> "f()"))))
|
|
(if (eq? v #f)
|
|
#f
|
|
v)))
|
|
|
|
(define-syntax wvv
|
|
(syntax-rules ()
|
|
((_ name type-pred? convert)
|
|
(define/contract (name wv id)
|
|
(-> wv? symbol? (or/c type-pred? boolean?))
|
|
(let ((v (webview-value wv id)))
|
|
(if (eq? v #f)
|
|
#f
|
|
(convert v))))
|
|
)
|
|
)
|
|
)
|
|
|
|
(wvv webview-value/time g:time? string->time)
|
|
(wvv webview-value/date g:date? string->date)
|
|
(wvv webview-value/datetime g:datetime? string->datetime)
|
|
(wvv webview-value/number number? string->number)
|
|
(wvv webview-value/symbol symbol? string->symbol)
|
|
(wvv webview-value/bool boolean? (λ (e) (if (string=? e "true") #t #f)))
|
|
|
|
|
|
(define/contract (webview-add-class! wv id-or-selector class)
|
|
(-> wv? (or/c symbol? string?) (or/c symbol? string? list?) hash?)
|
|
(let ((sel (if (symbol? id-or-selector)
|
|
(format "#~a" id-or-selector)
|
|
id-or-selector))
|
|
(cl (mk-js-array class))
|
|
)
|
|
(webview-call-js wv (with-selector sel
|
|
(format
|
|
(js-code
|
|
"function(id, el) {"
|
|
" let cl = ~a;"
|
|
" cl.forEach(function(c) {"
|
|
" el.classList.add(c);"
|
|
" });"
|
|
" return id;"
|
|
"}") cl)))
|
|
)
|
|
)
|
|
|
|
(define/contract (webview-remove-class! wv id-or-selector class)
|
|
(-> wv? (or/c symbol? string?) (or/c symbol? string? list?) hash?)
|
|
(let ((sel (if (symbol? id-or-selector)
|
|
(format "#~a" id-or-selector)
|
|
id-or-selector))
|
|
(cl (mk-js-array class))
|
|
)
|
|
(webview-call-js wv
|
|
(with-selector sel
|
|
(format
|
|
(js-code
|
|
"function(id, el) {"
|
|
" let cl = ~a;"
|
|
" cl.forEach(function(c) {"
|
|
" el.classList.remove(c);"
|
|
" });"
|
|
" return id;"
|
|
"}") cl))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define/contract (webview-set-style! wv selector style-entries)
|
|
(-> wv? (or/c symbol? string?) (or/c kv? list-of-kv?) hash?)
|
|
(let ((sel (if (symbol? selector)
|
|
(format "#~a" selector)
|
|
selector))
|
|
(cl (mk-js-array (if (kv? style-entries)
|
|
(list style-entries)
|
|
style-entries)))
|
|
)
|
|
(webview-call-js wv
|
|
(with-selector sel
|
|
(format
|
|
(js-code
|
|
"function(id, el) {"
|
|
" let cl = ~a;"
|
|
" cl.forEach(function(st) {"
|
|
" el.style[st[0]] = st[1];"
|
|
" });"
|
|
" return id;"
|
|
"}") cl))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define/contract (webview-unset-style! wv selector style-entries)
|
|
(-> wv? (or/c symbol? string?) (or/c symbol? list-of-symbol?) hash?)
|
|
(let ((sel (if (symbol? selector)
|
|
(format "#~a" selector)
|
|
selector))
|
|
(cl (mk-js-array (if (symbol? style-entries)
|
|
(list style-entries)
|
|
style-entries)))
|
|
)
|
|
(webview-call-js wv
|
|
(with-selector sel
|
|
(format
|
|
(js-code
|
|
"function(id, el) {"
|
|
" let cl = ~a;"
|
|
" cl.forEach(function(st) {"
|
|
" el.style[st] = '';"
|
|
" });"
|
|
" return id;"
|
|
"}") cl)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define/contract (webview-set-attr! wv selector attr-entries)
|
|
(-> wv? (or/c symbol? string?)
|
|
(or/c kv? list-of-kv?) hash?)
|
|
(let* ((sel (if (symbol? selector)
|
|
(format "#~a" selector)
|
|
selector))
|
|
(ae* (if (kv? attr-entries) (list attr-entries) attr-entries))
|
|
(ae** (map (λ (kv)
|
|
(let ((v (kv-2 kv)))
|
|
(make-kv (kv-1 kv)
|
|
(cond
|
|
([g:date? v] (date->string v))
|
|
([g:time? v] (time->string v))
|
|
([g:datetime? v] (datetime->string v))
|
|
(else (format "~a" v))))
|
|
)) ae*))
|
|
(cl (mk-js-array ae**))
|
|
)
|
|
(webview-call-js wv
|
|
(with-selector sel
|
|
(format
|
|
(js-code
|
|
"function(id, el) {"
|
|
" let cl = ~a;"
|
|
" cl.forEach(function(av) {"
|
|
" el.setAttribute(av[0], av[1]);"
|
|
" });"
|
|
" return id;"
|
|
"}") cl))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define/contract (webview-attr wv id attr)
|
|
(-> wv? symbol? (or/c symbol? string?) (or/c string? boolean?))
|
|
(let ((v (webview-call-js wv
|
|
(with-id id el
|
|
-> (format "el.getAttribute('~a');" attr))
|
|
)))
|
|
(if (eq? v 'null)
|
|
#f
|
|
v)
|
|
)
|
|
)
|
|
|
|
(define-syntax wva
|
|
(syntax-rules ()
|
|
((_ name type-pred? convert)
|
|
(define/contract (name wv id attr)
|
|
(-> wv? symbol? (or/c symbol? string?) (or/c type-pred? boolean?))
|
|
(let ((v (webview-attr wv id attr)))
|
|
(if (eq? v #f)
|
|
#f
|
|
(convert v))))
|
|
)
|
|
)
|
|
)
|
|
|
|
(wva webview-attr/number number? string->number)
|
|
(wva webview-attr/symbol symbol? string->symbol)
|
|
(wva webview-attr/date g:date? string->date)
|
|
(wva webview-attr/time g:time? string->time)
|
|
(wva webview-attr/datetime g:datetime string->datetime)
|
|
(wvv webview-attr/bool boolean? (λ (e) (if (string=? e "true") #t #f)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; testing
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-runtime-path example-path "../example")
|
|
|
|
(define file-getter (webview-standard-file-getter example-path))
|
|
|
|
(define (test)
|
|
(let* ((cb (λ (handle evt)
|
|
(displayln evt)))
|
|
(h (webview-create 'test file-getter cb))
|
|
)
|
|
(webview-set-title! h "This is a test window")
|
|
(webview-resize h 800 600)
|
|
(webview-move h 350 220)
|
|
;(webview-present h)
|
|
h))
|
|
|
|
|
|
; (while (not (webview-has-events? h))
|
|
; (displayln "Waiting...")
|
|
; (sleep 1))
|
|
; (let ((evt (webview-get-event h)))
|
|
; (when (string=? (hash-ref evt 'evt) "html-loaded")
|
|
; (webview-bind h "button" "click")))
|
|
; h)) |