Separation of concerns.

private/web-racket-version.rkt

@@ -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))
+
+  )

private/web-racket.rkt

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

private/web-wire.rkt

@@ -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
@@ -86,96 +84,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
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

private/webui-wire-download.rkt

@@ -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)
+              ))
+          ))))  
+  )

private/webui-wire.rkt

@@ -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)))
+  

private/ww-time.rkt

@@ -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