hack it

pollen/app.rkt

@@ -2,7 +2,8 @@
 (require pollen/private/log
          pollen/private/command
          pollen/setup
-         pollen/private/project-server)
+         pollen/private/project-server
+         net/sendurl)
 
 (define app-mono-fam
   (for*/first ([preferred
@@ -37,7 +38,7 @@
   (send directory-msg set-label (if val (path->string val) "")))
 
 (module+ main
-(set-current-manager-directory (expand-user-path "~/git/bpt/")))
+  (set-current-manager-directory (expand-user-path "~/git/bpt/")))
 
 (define button-directory
   (let ([str "Select project directory"])
@@ -111,24 +112,23 @@
   (send dialog-message set-label str)
   (send dialog-alert show #t))
 
-
 (define button-start
   (new button%	 
        [label "Start project server"]	 
        [parent hpanel-server-controls]
        [callback (λ (button evt)
-                   (match (current-manager-directory)
+                   (if (current-server-stopper)
-                     [#false (make-alert "No project directory selected.")]
+                       (make-alert "Project server already running.")
-                     [dir 
+                       (match (current-manager-directory)
-                      (message "starting project server")
+                         [#false (make-alert "No project directory selected.")]
-                      (define cthd (current-thread))
+                         [dir 
-                      (define server-thd
+                          (message "starting project server")
-                        (thread (λ ()
+                          ;; stopper is a function that sends a break signal
-                                  (parameterize ([current-project-root dir])
+                          ;; to the web server thread, wherever it is
-                                    (define stop
+                          (define stopper
-                                      (start-server (setup:main-pagetree dir) #:serve-only #true))
+                            (parameterize ([current-project-root dir])
-                                    (thread-send cthd stop)))))
+                              (start-server (setup:main-pagetree dir) #:return #true)))
-                      (current-server-stopper (thread-receive))]))]))
+                          (current-server-stopper stopper)])))]))
 
 (define button-stop
   (new button%	 
@@ -147,9 +147,14 @@
        [label "Launch browser"]	 
        [parent hpanel-server-controls]
        [callback (λ (button evt)
-                   (match (current-server-stopper)
+                   (cond
-                     [#false (make-alert "Project server not running.")]
+                     [(current-server-stopper)
-                     [dir #R 'wish-i-could-launch]))]))
+                      (send-url
+                       (format "http://localhost:~a/~a"
+                               (current-server-port)
+                               (setup:main-pagetree (current-manager-directory)))
+                       #false)]
+                     [else (make-alert "Project server not running.")]))]))
 
 (define status-box
   (let* ([wb (new text-field%
@@ -170,8 +175,6 @@
             (for ([vec (in-producer (λ () (sync rcvr)))])
               (match-define (vector _ msg _ _) vec)
               (send status-box-ed insert msg)
-              (send status-box-ed insert "\n")
+              (send status-box-ed insert "\n")))))
-              (sleep 0)))))
-
 
 (send window show #t)

pollen/private/project-server-routes.rkt

@@ -58,15 +58,16 @@
 ;; print message to console about a request
 (define/contract (logger req)
   (request? . -> . void?) 
-  (define localhost-client "::1")
+  (define localhost-names '("::1" "fe80::1%lo0" "127.0.0.1"))
   (define url-string (url->string (request-uri req)))
   (unless (ends-with? url-string "favicon.ico")
     (message (match url-string
                [(regexp #rx"/$") (string-append url-string " directory default page")]
                [_ (string-replace url-string (setup:main-pagetree) " dashboard")])
              (match (request-client-ip req)
-               [(== localhost-client) ""]
+               [client #:when (not (member client localhost-names))
-               [client (format "from ~a" client)]))))
+                       (format "from ~a" client)]
+               [_ ""]))))
 
 ;; pass string args to route, then
 ;; package route into right format for web server

pollen/private/project-server.rkt

@@ -1,7 +1,15 @@
-#lang web-server/base
+#lang racket/base
 (require racket/runtime-path
          web-server/servlet-env 
          web-server/dispatch
+         web-server/web-server
+         web-server/servlet-dispatch
+         web-server/private/mime-types
+         (prefix-in files: web-server/dispatchers/dispatch-files)
+         (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
+         web-server/dispatchers/filesystem-map
+         net/url
+         net/sendurl
          "project-server-routes.rkt" 
          "log.rkt" 
          "../setup.rkt"
@@ -12,20 +20,28 @@
 
 (define-runtime-path mime-types "server-extras/mime.types")
 
-(define (start-server servlet-path [open-browser-window? #f]
+(define (make-static-dispatcher-sequence . pths)
-                      #:serve-only [serve-only? #false])
+  (apply sequencer:make
-  (define-values (pollen-servlet _)
+         (for/list ([pth (in-list pths)])
-    (dispatch-rules
+           (files:make
-     [((string-arg) ... (? (λ (x) (string=? "" x)))) route-index] ; last element of a "/"-terminated url is ""
+            #:path->mime-type (make-path->mime-type mime-types)
-     [((string-arg) ... (? pagetree-source?)) route-dashboard]
+            #:url->path (make-url->path (path->string pth))))))
-     [((string-arg) ... "in" (string-arg) ...) route-in]
+
-     [((string-arg) ... "out" (string-arg) ...) route-out]
+(define-values (pollen-servlet _)
-     [else route-default]))
+  (dispatch-rules
+   ;; last element of a "/"-terminated url is ""
+   [((string-arg) ... "") route-index] 
+   [((string-arg) ... (? pagetree-source?)) route-dashboard]
+   [((string-arg) ... "in" (string-arg) ...) route-in]
+   [((string-arg) ... "out" (string-arg) ...) route-out]
+   [else route-default]))
+
+(define (start-server servlet-path [open-browser-window? #false] #:return [return? #false])
   
+  (define server-name (format "http://localhost:~a" (current-server-port)))
+
   (message (format "welcome to Pollen ~a (Racket ~a)" pollen:version (version)))
   (message (format "project root is ~a" (current-project-root)))
-  
-  (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)
@@ -35,24 +51,21 @@
                          [else (current-server-listen-ip)]))
                "project server permitting access to all clients"))
   (message "ready to rock")
-
+  
-  (cond
+  (define stop-func
-    [serve-only?
+    (parameterize ([error-print-width 1000])
-     (define stopper
+      (serve
-       ((dynamic-require 'web-server/web-server 'serve)
+       #:dispatch (sequencer:make
-        #:dispatch ((dynamic-require 'web-server/servlet-dispatch 'dispatch/servlet) pollen-servlet)
+                   (dispatch/servlet pollen-servlet)
-        #:listen-ip (current-server-listen-ip)
+                   (make-static-dispatcher-sequence
-        #:port (current-server-port)))
+                    (current-project-root)
-     stopper]
+                    (current-server-extras-path))
-    [else
+                   (dispatch/servlet route-404))
-     (parameterize ([error-print-width 1000])
+       #:listen-ip (current-server-listen-ip)
-       (serve/servlet pollen-servlet
+       #:port (current-server-port))))
-                      #:launch-browser? open-browser-window?
+  (when open-browser-window?
-                      #:servlet-path servlet-path
+    (send-url (string-append server-name servlet-path)))
-                      #:port (current-server-port)
+  (if return?
-                      #:listen-ip (current-server-listen-ip)
+      stop-func
-                      #:servlet-regexp #rx"" ; respond to top level
+      (with-handlers ([exn:break? (λ (e) (stop-func) (message "project server stopped"))])
-                      #:command-line? #true
+        (do-not-return))))
-                      #:file-not-found-responder route-404
-                      #:mime-types-path mime-types
-                      #:extra-files-paths (list (current-server-extras-path) (current-project-root))))]))