#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-set-html! 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] [request-count #:mutable] [sec-token-cache #:mutable] [cert-ou-token #: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 "" (string-append "" "\n" "" "\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* ((f1 "c:/tmp/my.crt") (f2 "c:/tmp/my.key") (fh1 (open-output-file f1 #:exists 'replace)) (fh2 (open-output-file f2 #:exists 'replace))) (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 ) ) ) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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 (webview-create file-getter event-callback #:boilerplate-js [bj (λ () (default-boilerplate-js))] #:parent [p #f]) (let* ((h (make-wv #f 0 -1 file-getter bj #f 0 (make-lru 250 #:cmp eq?) (symbol->string (make-security-token)))) (cert (generate-self-signed-cert 2048 365 '("127.0.0.1" "localhost") "NL" "Dijkema" #:ou (wv-cert-ou-token h))) (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)) (event-processor (λ (wv evt) (event-callback h (util-parse-event evt)))) (ph (if (wv? p) (wv-handle p) #f)) (wv (rkt-webview-create ph event-processor)) (base-req (format "https://127.0.0.1:~a" (wv-port h))) ) (set-wv-handle! h wv) (set-wv-window-nr! h (rkt-wv-win wv)) (set-wv-webserver-thread! h server) (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?) (if (url? url) (rkt-webview-set-url! (wv-handle wv) (url->string url)) (rkt-webview-set-url! (wv-handle wv) url) ) ) (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 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))