-

private/racket-webview.rkt

@@ -2,6 +2,7 @@
 
 (require "racket-webview-qt.rkt"
          "utils.rkt"
+         "mimetypes.rkt"
          web-server/servlet
          web-server/servlet-env
          web-server/http
@@ -11,6 +12,9 @@
          racket/string
          racket/path
          racket/port
+         racket/contract
+         xml
+         xml/xexpr
          json
          )
 
@@ -19,11 +23,32 @@
          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-bind!
-         webview-standard-file-getter
+         webview-set-title!
+         webview-set-url!
+         webview-set-html!
+
+         webview-set-innerHTML!
+         webview-set-value!
+         webview-value
+         webview-value/bool
+         webview-value/symbol
+         webview-value/number
          
+         webview-add-class!
+         webview-remove-class!
+         webview-set-style!
+         
+         webview-standard-file-getter
          )
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -45,7 +70,8 @@
    [window-nr #:mutable]
    [file-getter #:mutable]
    [boilerplate-js #:mutable]
-   [webserver-thread #:mutable]))
+   [webserver-thread #:mutable])
+  #:transparent)
 
 (define (process-html wv-handle path out)
   (let ((html (file->string path))
@@ -59,7 +85,7 @@
 
 (define (process-file wv-handle ext path out)
   (let ((content (file->bytes path)))
-    (write bytes out)))
+    (display content out)))
 
 (define (web-serve wv-handle req)
   (let* ((path (url->string (request-uri req)))
@@ -71,6 +97,7 @@
            )
       (if (file-exists? file-to-serve)
           (response/output
+           #:mime-type (string->bytes/utf-8 (mimetype-for-ext ext))
            (λ (out)
              (if (or (eq? ext 'html) (eq? ext 'htm))
                  (process-html wv-handle file-to-serve out)
@@ -95,7 +122,8 @@
              #:servlet-path ""
              #:stateless? #t
              ;#:launch-browser #f
-             #:servlet-regexp #rx""))))
+             #:servlet-regexp #rx"")
+            )))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -106,6 +134,41 @@
   (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))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Webview functions
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -130,30 +193,75 @@
     (set! current-servlet-port (+ current-servlet-port 1))
     h))
 
-(define (webview-devtools wv)
+(define/contract (webview-devtools wv)
+  (-> wv? symbol?)
   (rkt-webview-open-devtools (wv-handle wv)))
 
-(define (webview-move wv x y)
+(define/contract (webview-move wv x y)
+  (-> wv? number? number? symbol?)
   (rkt-webview-move (wv-handle wv) x y))
 
-(define (webview-resize wv w h)
+(define/contract (webview-resize wv w h)
+  (-> wv? number? number? symbol?)
   (rkt-webview-resize (wv-handle wv) w h))
 
-(define (webview-close wv)
-  (rkt-webview-close (wv-handle wv))
-  (kill-thread (wv-webserver-thread wv))
+(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-set-title! wv title)
+  (-> wv? string? symbol?)
+  (rkt-webview-set-title! (wv-handle wv) title))
+
+(define/contract (webview-close wv)
+  (-> wv? symbol?)
+  (let ((r (rkt-webview-close (wv-handle wv))))
+    (kill-thread (wv-webserver-thread wv))
+    r)
   )
 
-(define (webview-bind! wv selector event)
+(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)))
-    (webview-run-js wv
-                (format "window.rkt_bind_evt_ids(~a, '~a', '~a')"
-                        (wv-window-nr wv) sel evt))))
+    (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 (webview-run-js wv js)
+(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
@@ -168,9 +276,166 @@
             (on-not-exist file base-path p)
             p)))))
 
+
 (define (webview-call-js wv js)
-  (let ((result (rkt_webview_call_js (wv-handle wv) js)))
-    result))
+  (-> 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 "Error calling javascript. Message: ~a" (hash-ref (fromJson (cadr result)) 'exn result))
+            )
+        (error "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?) 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")
+                     (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? (car v) 'oke)
+        (let ((h (fromJson (cadr v))))
+          (hash-ref h 'result #f))
+        #f)
+    )
+  )
+
+(define/contract (webview-value/number wv id)
+  (-> wv? symbol? (or/c number? boolean?))
+  (let ((v (webview-value wv id)))
+    (if (eq? v #f)
+        #f
+        (string->number (webview-value wv id)))))
+
+(define/contract (webview-value/symbol wv id)
+  (-> wv? symbol? (or/c symbol? boolean?))
+  (let ((v (webview-value wv id)))
+    (if (eq? v #f)
+        #f
+        (string->symbol (webview-value wv id)))))
+
+(define/contract (webview-value/bool wv id)
+  (-> wv? symbol? (or/c symbol? boolean?))
+  (let ((v (webview-value wv id)))
+    (if (eq? v #f)
+        'fail
+        (if (string=? (webview-value wv id) "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 list? list-of-kv?) hash?)
+
+(define (webview-set-style!* wv selector h)
+  (list wv selector h))
+
+
+(define-syntax webview-style-entry
+  (syntax-rules ()
+    ((_ h (k v))
+     (with-handlers ([exn:fail? (λ (e)
+                                  (hash-set! h 'k v))])
+       (hash-set! h k v)))
+    ((_ h q l)
+     (hash-set! h (car l) (cadr l)))
+    ((_ h l)
+     (hash-set! h (car l) (cadr l)))
+    )
+  )
+
+(define-syntax webview-set-style!
+  (syntax-rules ()
+    ((_ wv selector st ...)
+     (webview-set-style!* wv selector 
+                          (let ((h (make-hash)))
+                            (webview-style-entry h st)
+                            ...
+                            h))
+     )
+    )
+  )
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; testing
@@ -184,6 +449,10 @@
   (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))