app harder

pollen/app.rkt

@@ -1,6 +1,8 @@
 #lang debug racket/gui
 (require pollen/private/log
-         pollen/private/command)
+         pollen/private/command
+         pollen/setup
+         pollen/private/project-server)
 
 (define app-mono-fam
   (for*/first ([preferred
@@ -14,7 +16,7 @@
 
 (define window (new frame% [label "Pollen Helper"]
                     [width 700]
-                    [height 700]
+                    [height 500]
                     [x 40]
                     [y 40]
                     [alignment '(left top)]
@@ -28,6 +30,7 @@
 
 (define hpanel-select (make-hpanel))
 (define current-manager-directory (make-parameter #f))
+(define current-server-stopper (make-parameter #f))
 
 (define (set-current-manager-directory val)
   (current-manager-directory val)
@@ -38,7 +41,11 @@
     (new button%	 
          [label str]	 
          [parent hpanel-select]
-         [callback (λ (button evt) (set-current-manager-directory (get-directory str)))])))
+         [callback (λ (button evt)
+                     (define dir (get-directory str))
+                     (when dir
+                       (set-current-manager-directory dir)
+                       (set-server-port (setup:project-server-port dir))))])))
 
 (define directory-msg
   (new message%	 
@@ -46,16 +53,61 @@
        [parent hpanel-select]
        [auto-resize #true]))
 
+(define hpanel-server-options (make-hpanel))
+
+(define server-option-port
+  (new text-field%
+       [parent hpanel-server-options]
+       [label "server port"]
+       [min-width 150]
+       [stretchable-width #false]
+       [init-value (number->string (setup:project-server-port))]
+       [callback (λ (tf evt)
+                   (set-server-port (string->number (send tf get-value))))]))
+
+(define (set-server-port num)
+  (when (number? num)
+    (current-server-port num)
+    (send server-option-port set-value (number->string num))))
+  
+
+(define server-option-local
+  (new check-box%
+       [parent hpanel-server-options]
+       [label "local only"]
+       [callback (λ (cb evt)
+                   (current-server-listen-ip (and (send cb get-value) "127.0.0.1")))]))
+
 (define hpanel-server-controls (make-hpanel))
 
+(define dialog-alert (new dialog%
+                          [label "Error"]
+                          [border 6]
+                          [spacing 6]
+                          [parent #f]))
+
+(define dialog-message (new message%
+                            [parent dialog-alert]
+                            [auto-resize #t]
+                            [label ""]))
+
+(define dialog-alert-button-pane
+  (new horizontal-pane%
+       [parent dialog-alert]
+       [alignment '(right bottom)]))
+
+(define dialog-alert-button-ok
+  (new button%
+       [parent dialog-alert-button-pane]
+       [label "OK"]
+       [style '(border)]
+       [callback (λ (button evt)
+                   (send dialog-alert show #f))]))
+
 (define (make-alert str)
-  (define d (new dialog%
-                 [label str]
-                 [width 300]
-                 [height 300]
-                 [parent #f]))
-  #R d
-  #R (send d show #f))
+  (send dialog-message set-label str)
+  (send dialog-alert show #t))
+
 
 (define button-start
   (new button%	 
@@ -63,31 +115,62 @@
        [parent hpanel-server-controls]
        [callback (λ (button evt)
                    (match (current-manager-directory)
-                     [#false (make-alert "boo")]
-                     [dir
-                   (with-logging-to-port
-                       (current-error-port)
-                     (λ () (start-project-server dir))
-                     #:logger pollen-logger
-                     'info
-                     'pollen)]))]))
+                     [#false (make-alert "No project directory selected.")]
+                     [dir 
+                      (message "starting project server")
+                      (define cthd (current-thread))
+                      (define server-thd
+                        (thread (λ ()
+                                  (parameterize ([current-project-root dir])
+                                    (define stop
+                                      (start-server (format "/~a" (setup:main-pagetree dir)) #:serve-only #true))
+                                    (thread-send cthd stop)
+                                    (with-handlers ([exn:break? (λ (e) (stop))])
+                                      (sync/enable-break never-evt))))))
+                      (current-server-stopper (thread-receive))]))]))
 
 (define button-stop
   (new button%	 
        [label "Stop project server"]	 
        [parent hpanel-server-controls]
-       [callback (λ (button evt) (void))]))
-
-(define wordbox (let* ([wb (new text-field%
-                                [label #f]
-                                [style '(multiple)]
-                                [parent window]
-                                [font (make-font #:face app-mono-fam #:size app-font-size)])]
-                       [ed (send wb get-editor)])
-                  (send ed set-line-spacing (* app-font-size 0.4))
-                  (send ed set-padding 6 3 6 3)
-                  wb))
-
+       [callback (λ (button evt)
+                   (match (current-server-stopper)
+                     [#false (make-alert "Project server not running.")]
+                     [stopper-proc 
+                      (stopper-proc)
+                      (current-server-stopper #false)
+                      (message "project server stopped")]))]))
+
+(define button-launch
+  (new button%	 
+       [label "Launch browser"]	 
+       [parent hpanel-server-controls]
+       [callback (λ (button evt)
+                   (match (current-server-stopper)
+                     [#false (make-alert "Project server not running.")]
+                     [dir #R 'wish-i-could-launch]))]))
+
+(define status-box
+  (let* ([wb (new text-field%
+                  [label #f]
+                  [style '(multiple)]
+                  [parent window]
+                  [font (make-font #:face app-mono-fam #:size app-font-size)])]
+         [ed (send wb get-editor)])
+    (send ed set-line-spacing (* app-font-size 0.4))
+    (send ed set-padding 6 3 6 3)
+    wb))
+
+(define status-box-ed (send status-box get-editor))
+
+(define log-receiver-thread
+  (thread (λ ()
+            (define rcvr (make-log-receiver pollen-logger 'info 'pollen))
+            (for ([vec (in-producer (λ () (sync rcvr)))])
+              (match-define (vector _ msg _ _) vec)
+              (send status-box-ed insert msg)
+              (send status-box-ed insert "\n")
+              (sleep 0)))))
 
 
 (send window show #t)

pollen/private/project-server.rkt

@@ -12,7 +12,8 @@
 
 (define-runtime-path mime-types "server-extras/mime.types")
 
-(define (start-server servlet-path [open-browser-window? #f])
+(define (start-server servlet-path [open-browser-window? #f]
+                      #:serve-only [serve-only? #false])
   (define-values (pollen-servlet _)
     (dispatch-rules
      [((string-arg) ... (? (λ (x) (string=? "" x)))) route-index] ; last element of a "/"-terminated url is ""
@@ -27,16 +28,31 @@
   (define server-name (format "http://localhost:~a" (current-server-port)))
   (message (format "project server is ~a (Ctrl+C to exit)" server-name))
   (message (format "project dashboard is ~a/~a" server-name (setup:main-pagetree)))
+  (message (if (current-server-listen-ip)
+               (format "project server permitting access only to ~a"
+                       (case (current-server-listen-ip)
+                         [("127.0.0.1") "localhost"]
+                         [else (current-server-listen-ip)]))
+               "project server permitting access to all clients"))
   (message "ready to rock")
-  
-  (parameterize ([error-print-width 1000])
-    (serve/servlet pollen-servlet
-                   #:launch-browser? open-browser-window?
-                   #:servlet-path servlet-path
-                   #:port (current-server-port)
-                   #:listen-ip (current-server-listen-ip)
-                   #:servlet-regexp #rx"" ; respond to top level
-                   #:command-line? #true
-                   #:file-not-found-responder route-404
-                   #:mime-types-path mime-types
-                   #:extra-files-paths (list (current-server-extras-path) (current-project-root)))))
+
+  (cond
+    [serve-only?
+     (define stopper
+       ((dynamic-require 'web-server/web-server 'serve)
+        #:dispatch ((dynamic-require 'web-server/servlet-dispatch 'dispatch/servlet) pollen-servlet)
+        #:listen-ip (current-server-listen-ip)
+        #:port (current-server-port)))
+     stopper]
+    [else
+     (parameterize ([error-print-width 1000])
+       (serve/servlet pollen-servlet
+                      #:launch-browser? open-browser-window?
+                      #:servlet-path servlet-path
+                      #:port (current-server-port)
+                      #:listen-ip (current-server-listen-ip)
+                      #:servlet-regexp #rx"" ; respond to top level
+                      #:command-line? #true
+                      #:file-not-found-responder route-404
+                      #:mime-types-path mime-types
+                      #:extra-files-paths (list (current-server-extras-path) (current-project-root))))]))