webview

;;
;; MIT License
;;
;; Copyright (c) 2018 Thomas Chust
;;
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
;;

(module webview
  (webview?
   webview webview-terminate!
   webview-title-set! webview-fullscreen-set!
   webview-eval webview-inject webview-dialog webview-log
   char-set:no-js-escape write-js html-tag-rule write-html)

(import
  scheme
  (chicken base)
  (chicken condition)
  (chicken fixnum)
  (chicken bitwise)
  (chicken foreign)
  (only (chicken port) call-with-output-string)
  (only (chicken memory) tagged-pointer? tag-pointer)
  (only (chicken gc) set-finalizer!)
  (only srfi-1 every)
  (prefix (only utf8 string-length string-ref display) utf8-)
  (only srfi-13 string-trim string-pad)
  utf8-srfi-14
  (prefix unicode-char-sets unicode-)
  srfi-18
  srfi-69)

(foreign-declare
  "#include <webview.h>")

(define (type-error location message . arguments)
  (abort
   (make-composite-condition
    (make-property-condition
     'exn
     'location location
     'message message
     'arguments arguments)
    (make-property-condition
     'type))))

(define tag:webview
  (gensym 'webview))
(define webview?
  (cut tagged-pointer? <> tag:webview))
(define-foreign-type webview (c-pointer "webview_t")
  (lambda (v)
    (and v (if (webview? v) v (type-error 'webview "bad argument type" v))))
  (lambda (v)
    (and v (tag-pointer v tag:webview))))
(define-foreign-type nonnull-webview (nonnull-c-pointer "webview_t")
  (lambda (v)
    (if (webview? v) v (type-error 'webview "bad argument type" v)))
  (lambda (v)
    (tag-pointer v tag:webview)))

(define webview-callbacks
  (make-mutex 'webview-callbacks))
(mutex-specific-set!
  webview-callbacks
  (make-hash-table equal? equal?-hash))

(define-external (on_webview_external_invoke [nonnull-webview view] [(const c-string) data]) void
  (mutex-lock! webview-callbacks)
  (let ([proc (hash-table-ref (mutex-specific webview-callbacks) view)])
    (mutex-unlock! webview-callbacks)
    (when proc
      (handle-exceptions
        exn (webview-log
             (string-trim
              (call-with-output-string
               (cut print-error-message exn <> "Callback Error"))))
        (proc view data)))))

(define (webview title proc #!key [url #f] [width 800] [height 600] [resizable? #t] [debug? #f])
  (letrec ([view
            ((foreign-lambda
              webview "webview_new"
              nonnull-c-string c-string int int bool bool)
             title url width height resizable? debug?)]
           [loop
            (lambda ()
              (when (zero?
                     ((foreign-safe-lambda
                       int "webview_loop"
                       nonnull-webview bool)
                      view #t))
                (loop)))])
    (if view
      (set-finalizer!
       view
       (foreign-lambda
        void "webview_destroy"
        nonnull-webview))
      (error 'webview "initialization failed"))
    (when proc
      (mutex-lock! webview-callbacks)
      (hash-table-set! (mutex-specific webview-callbacks) view proc)
      (mutex-unlock! webview-callbacks)
      ((foreign-lambda*
        void ([nonnull-webview view])
        "webview_set_external_invoke_cb(view, on_webview_external_invoke);")
       view))
    (loop)))

(define webview-terminate!
  (foreign-safe-lambda
   void "webview_terminate"
   nonnull-webview))

(define webview-title-set!
  (foreign-safe-lambda
   void "webview_set_title"
   nonnull-webview nonnull-c-string))

(define webview-fullscreen-set!
  (foreign-safe-lambda
   void "webview_set_fullscreen"
   nonnull-webview bool))

(define (webview-eval view script)
  (unless (zero?
           ((foreign-safe-lambda
             int "webview_eval"
             nonnull-webview nonnull-c-string)
            view script))
    (error 'webview-eval "JavaScript evaluation failed")))

(define (webview-inject view id html)
  (webview-eval
   view
   (call-with-output-string
    (lambda (port)
      (display "document.getElementById(" port)
      (write-js id port)
      (display ").innerHTML = " port)
      (write-js
       (call-with-output-string (cut write-html html <>))
       port)
      (display ";" port)))))

(define (webview-dialog view title #!optional value #!rest type)
  (let ([type
         (cond
           [(memq #:open type)
            (foreign-value "WEBVIEW_DIALOG_TYPE_OPEN" int)]
           [(memq #:save type)
            (foreign-value "WEBVIEW_DIALOG_TYPE_SAVE" int)]
           [else
            (foreign-value "WEBVIEW_DIALOG_TYPE_ALERT" int)])]
        [flags
         (bitwise-ior
           (if (memq #:directory type)
             (foreign-value "WEBVIEW_DIALOG_FLAG_DIRECTORY" int)
             (foreign-value "WEBVIEW_DIALOG_FLAG_FILE" int))
           (cond
             [(memq #:error type)
              (foreign-value "WEBVIEW_DIALOG_FLAG_ERROR" int)]
             [(memq #:warning type)
              (foreign-value "WEBVIEW_DIALOG_FLAG_WARNING" int)]
             [else
              (foreign-value "WEBVIEW_DIALOG_FLAG_INFO" int)]))]
        [buf
         (make-string 4096 #\nul)])
    ((foreign-safe-lambda
      void "webview_dialog"
      nonnull-webview int int nonnull-c-string c-string
      scheme-pointer size_t)
     view type flags title value
     buf (string-length buf))
    (let scan ([pos 0])
      (if (or (fx>= pos (string-length buf))
              (eqv? (string-ref buf pos) #\nul))
        (and (fx> pos 0) (substring buf 0 (fx- pos 1)))
        (scan (fx+ pos 1))))))

(define webview-log
  (foreign-lambda
   void "webview_print_log"
   nonnull-c-string))

(define alist:js-escape
  '((#\' . #\') (#\" . #\") (#\\ . #\\)
    (#\backspace . #\b) (#\tab . #\t)
    (#\newline . #\n) (#\return . #\r)))

(define char-set:no-js-escape
  (char-set-difference
   (char-set-union
    unicode-char-set:alphabetic
    char-set:digit
    char-set:punctuation
    char-set:symbol
    char-set:blank)
   (list->char-set (map car alist:js-escape))))

(define (write-js s #!optional [port (current-output-port)] [quotes #\"])
  (let ([n (utf8-string-length s)])
    (cond [quotes => (cut utf8-display <> port)])
    (do ([i 0 (fx+ i 1)]) ((fx>= i n))
      (let ([c (utf8-string-ref s i)])
        (cond
         [(char-set-contains? char-set:no-js-escape c)
          (utf8-display c port)]
         [(assv c alist:js-escape)
          => (lambda (r)
               (utf8-display #\\ port)
               (utf8-display (cdr r) port))]
         [else
          (utf8-display "\\u" port)
          (utf8-display
           (string-pad
            (number->string (char->integer c) 16)
            4 #\0)
           port)])))
    (cond [quotes => (cut utf8-display <> port)])))

(define html-tag-rule
  (let ([tag-rules (make-hash-table eq? symbol-hash)])
    (case-lambda
      [(tag)
       (hash-table-ref/default tag-rules tag 'normal)]
      [(tag rule)
       (cond
         [(not (memq rule '(void raw normal)))
          (error 'html-tag-rule "invalid tag rule" tag rule)]
         [(eq? rule 'normal)
          (hash-table-delete! tag-rules tag)
          (void)]
         [else
          (hash-table-set! tag-rules tag rule)])])))

(for-each
  (lambda (tag&rule) (html-tag-rule (car tag&rule) (cdr tag&rule)))
  '([area . void]
    [base . void]
    [br . void]
    [col . void]
    [command . void]
    [embed . void]
    [hr . void]
    [img . void]
    [input . void]
    [keygen . void]
    [link . void]
    [meta . void]
    [param . void]
    [source . void]
    [track . void]
    [wbr . void]
    [script . raw]
    [style . raw]))

(define write-html
  (letrec ([write-escaped
            (lambda (s port)
              (let ([n (string-length s)])
                (do ([i 0 (fx+ i 1)]) ((fx>= i n))
                  (let ([c (string-ref s i)])
                    (display
                      (case c
                        [(#\") "&quot;"]
                        [(#\&) "&amp;"]
                        [(#\<) "&lt;"]
                        [(#\>) "&gt;"]
                        [else c])
                      port)))))]
           [write-element
            (lambda (elt port)
              (unless (and (pair? elt) (symbol? (car elt)) (list? (cdr elt)))
                (error 'write-html "not a proper element" elt))
              (let ([tag (car elt)]
                    [attributes&contents (cdr elt)])
                (when (eq? tag 'html)
                  (display "<!DOCTYPE html>" port)
                  (newline port))
                (display #\< port)
                (display tag port)
                (let-values ([(rule)
                              (html-tag-rule tag)]
                             [(attributes contents)
                              (cond
                               [(null? attributes&contents)
                                (values '() '())]
                               [(and (list? (car attributes&contents))
                                     (every pair? (car attributes&contents)))
                                (values (car attributes&contents) (cdr attributes&contents))]
                               [else
                                (values '() attributes&contents)])])
                  (for-each (cut write-attribute <> port) attributes)
                  (display #\> port)
                  (case rule
                    [(normal)
                     (for-each (cut write-content #t <> port) contents)]
                    [(raw)
                     (for-each (cut write-content #f <> port) contents)]
                    [(void)
                     (unless (null? contents)
                       (error 'write-html "void elements cannot have contents" elt))])
                  (case rule
                    [(normal raw)
                     (display "</" port)
                     (display tag port)
                     (display #\> port)]))
                (when (eq? tag 'html)
                  (newline port))))]
           [write-attribute
            (lambda (attr port)
              (unless (and (pair? attr) (symbol? (car attr)))
                (error 'write-html "not a proper attribute" attr))
              (let ([key (car attr)]
                    [v (cdr attr)])
                (cond
                  [(not v)
                   (void)]
                  [(boolean? v)
                   (display #\space port)
                   (display key port)]
                  [else
                   (display #\space port)
                   (display key port)
                   (display "=\"" port)
                   (if (list? v)
                     (for-each (cut write-content #f <> port) v)
                     (write-content #f v port))
                   (display #\" port)])))]
           [write-content
            (lambda (allow-elements? v port)
              (cond
               [(symbol? v)
                (display #\& port)
                (display v port)
                (display #\; port)]
               [(and (integer? v) (positive? v))
                (display "&#" port)
                (display v port)
                (display #\; port)]
               [(string? v)
                (write-escaped v port)]
               [allow-elements?
                (write-element v port)]
               [else
                (error 'write-html "element not allowed in this context" v)]))])
    (lambda (html #!optional [port (current-output-port)])
      (write-element html port))))

)

;; vim: set ai et ts=4 sts=2 sw=2 ft=scheme: ;;