more

pollen/app/app.rkt

@@ -0,0 +1,180 @@
+#lang debug racket/gui
+(require pollen/private/log
+         pollen/private/command
+         pollen/setup
+         pollen/private/project-server
+         net/sendurl)
+
+(define app-mono-fam
+  (for*/first ([preferred
+                '("Triplicate T4" "Menlo" "Consolas" "Andale Mono" "Courier")]
+               [mono-fam (in-list (get-face-list 'mono))]               
+               #:when (equal? preferred mono-fam))
+    preferred))
+
+(define app-font-size 14)
+(define app-font (make-font #:face (send normal-control-font get-face) #:size app-font-size))
+
+(define window (new frame% [label "Pollen Helper"]
+                    [width 700]
+                    [height 500]
+                    [x 40]
+                    [y 40]
+                    [alignment '(left top)]
+                    [spacing 6]
+                    [border 6]))
+
+(define (make-hpanel) (new horizontal-panel%
+                           [parent window]
+                           [alignment '(left top)]
+                           [stretchable-height #false]))
+
+(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)
+  (send directory-msg set-label (if val (path->string val) "")))
+
+(module+ main
+  (set-current-manager-directory (expand-user-path "~/git/bpt/")))
+
+(define button-directory
+  (let ([str "Select project directory"])
+    (new button%	 
+         [label str]	 
+         [parent hpanel-select]
+         [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%	 
+       [label ""]	 
+       [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)
+  (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)
+                   (if (current-server-stopper)
+                       (make-alert "Project server already running.")
+                       (match (current-manager-directory)
+                         [#false (make-alert "No project directory selected.")]
+                         [dir 
+                          (message "starting project server")
+                          ;; stopper is a function that sends a break signal
+                          ;; to the web server thread, wherever it is
+                          (define stopper
+                            (parameterize ([current-project-root dir])
+                              (start-server (setup:main-pagetree dir) #:return #true)))
+                          (current-server-stopper stopper)])))]))
+
+(define button-stop
+  (new button%	 
+       [label "Stop project server"]	 
+       [parent hpanel-server-controls]
+       [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)
+                   (cond
+                     [(current-server-stopper)
+                      (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%
+                  [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")))))
+
+(send window show #t)

pollen/app/make-pollen-icons.rkt

@@ -0,0 +1,13 @@
+#lang br
+(require pict icns file/ico rsvg)
+
+(define p (svg-file->pict "pollen-raw.svg"))
+(send (pict->bitmap p) save-file "pollen.png" 'png)
+
+(with-output-to-file "pollen.icns"
+  (λ () (void (write-bytes (pict->icns-bytes p))))
+  #:exists 'replace)
+
+(write-icos (for/list ([size '(16 32 48 256)])
+              (argb->ico size size (pict->argb-pixels (scale p (/ size 720))))) "pollen.ico"
+                                                           #:exists 'replace)

pollen/app/pollen-font.rkt

@@ -0,0 +1,142 @@
+#lang debug racket
+(require racket/gui sugar/coerce sugar/debug)
+(define current-cell-size (make-parameter 120))
+(define current-dc (make-parameter #f))
+(define current-target (make-parameter 'gui))
+(define current-stroke-scale (make-parameter 1))
+(define char-edge-size 6)
+
+
+(define (pathify vs)
+  (define p (new dc-path%))
+  (define pts (map (λ (x) (list (* (current-cell-size) (sub1 (modulo x 10))) (* (current-cell-size) (- 4 (sub1 (floor (/ x 10))))) )) vs))
+  (send p move-to (first (car pts)) (second (car pts)))
+  (for-each (λ (pt) (send p line-to (first pt) (second pt))) (cdr pts))
+  (when (= (first vs) (last vs)) (send p close))
+  p)
+
+(struct $glyph (name paths))
+
+(define font-definition 
+  '((a (51 54 45 15 12 21 31 33))
+    (b (11 51 55 25 14 13) (35 33))
+    (c (25 15 11 41 52 55 45))
+    (d (31 11 14 25 45 54 51))
+    (e (15 11 41 52 55 35 33))
+    (E (55 52 41 11 15) (31 35))
+    (f (11 41 52 55) (31 35))
+    (g (33 35 15 11 41 52 55))
+    (h (11 51) (15 55) (31 35))
+    (i (11 15) (51 55) (13 53))
+    (j (53 55 15 12 21 31))
+    (k (11 51) (11 21 54 55) (43 34 25 15))
+    (L (51 11 15) (53 33 35))
+    (l (25 15 11 41 52))
+    (m (11 51 54 45 15) (53 13))
+    (n (11 51 54 45 15))
+    (N (11 51 52 43 23 14 15 55))
+    (O (11 41 52 55 25 14 11))
+    (o (51 54 45 15 12 21 51))
+    (P (11 51 54 45 35 24 23))
+    (p (51 54 45 35 33 13 11 31))
+    (p0 (11 51 55 35 24 23))
+    (q (33 24 13 11 41 52 55 35 24))
+    (r (11 51 53 54 45 35 33 23 14 15))
+    (s (11 14 25 35 31 41 52 55))
+    (t (31 51 55 35) (53 13) (11 15))
+    (T (51 55) (53 13))
+    (u (51 21 12 15 55))
+    (v (55 35 13 11 51))
+    (w (51 21 12 15 55) (53 13))
+    (x (51 52 43 23 14 15) (11 12 23 43 54 55))
+    (X (51 41 32 34 25 15) (11 21 32 34 45 55))
+    (y (51 31 35)(55 25 14 11))
+    (z (51 55 45 34 32 21 11 15))
+    (♥ (12 21 41 52 43 54 45 25 14 12))
+    (0 (51 54 45 15 12 21 31 51))
+    (1 (51 53 13) (11 15))
+    (2 (51 54 45 35 31 11 15))
+    (3 (51 54 45 15 11) (31 35))
+    (4 (41 21 25) (54 14))
+    (5 (55 51 31 35 25 14 11))
+    (6 (31 35 25 14 11 41 52 55))
+    (7 (51 55 45 22 12))
+    (8 (12 21 51 54 45 15 12) (31 35))
+    (9 (11 14 25 55 52 41 31 35))
+    (λ (51 52 25 15) (11 21 43))
+    (> (51 52 25 15))
+    (% (11 51) (12 52) (13 53) (14 54) (15 55))
+    (^ (11 51) (12 42) (13 33) (14 24))
+    (< (11 21 43))
+    (|(| (55 54 43 23 14 15))
+    (|)| (51 52 43 23 12 11))))
+
+
+(define (type str [xoffset 0] [yoffset 0] #:color color-proc #:width width)
+  (define glyphs (map (λ (i) ($glyph (->string (car i)) (map pathify (cdr i)))) font-definition))
+  (cond
+    [(equal? str "") (void)]
+    [else
+     (define gname (substring str 0 1))
+     (define g (findf (λ (g) (equal? ($glyph-name g) gname)) glyphs))
+     (when g
+       (define pen (make-pen #:color (->string (color-proc)) #:width width #:style 'solid #:cap 'projecting #:join 'miter))
+       (send (current-dc) set-pen pen)
+       (send (current-dc) set-brush "white" 'transparent)
+       (for-each (λ (p) (send (current-dc) draw-path p (+ xoffset (current-cell-size)) (+ yoffset (current-cell-size)))) ($glyph-paths g)))
+     (type (substring str 1) (+ xoffset (* (current-cell-size) char-edge-size)) yoffset #:color color-proc #:width width)]))
+
+(define (layer-type str #:xoffset [xoffset 0] #:yoffset [yoffset 0] . attrs)
+  (define layers (for/list ([i (in-range 0 (length attrs) 2)]) (list (list-ref attrs i) (list-ref attrs (add1 i)))))
+  (for-each (λ (layer) (type str xoffset yoffset #:color (first layer) #:width (* (current-cell-size) (current-stroke-scale) (second layer)))) layers)) 
+
+(define (render text layers [stroke-scale 1] [name (gensym)])
+  (define lines (string-split text))
+  (define horiz (* (current-cell-size) (apply max (map string-length lines)) char-edge-size))
+  (define vert (* (current-cell-size) char-edge-size (length lines)))
+  (define target (make-bitmap horiz vert))
+  (parameterize ([current-dc (if (equal? 'svg (current-target))
+                                 (new svg-dc% [width horiz] [height vert] [output (format "/Users/MB/Desktop/~a.svg" name)] [exists 'replace])
+                                 (new bitmap-dc% [bitmap target]))]
+                 [current-stroke-scale stroke-scale])
+    (when (eq? 'svg (current-target))
+      (send (current-dc) start-doc "start")
+      (send (current-dc) start-page))
+    (send (current-dc) set-smoothing 'smoothed)
+    (for* ([(line lineno) (in-indexed lines)]
+           [layer (in-list layers)])
+      (define layer-color (first layer))
+      (define layer-thickness (second layer))
+      (layer-type line #:xoffset 0 #:yoffset (* (current-cell-size) char-edge-size lineno) layer-color layer-thickness))
+    (make-object image-snip% target)
+    (when (eq? 'svg (current-target))
+      (send (current-dc) end-page)
+      (send (current-dc) end-doc))
+    (when (eq? 'png (current-target))
+      (send target save-file (format "/Users/MB/Desktop/~a.png" name) 'png))))
+
+(define-syntax-rule (render-svg arg ...)
+  (parameterize ([current-target 'svg])
+    (render arg ...)))
+
+(define-syntax-rule (render-png arg ...)
+  (parameterize ([current-target 'png])
+    (render arg ...)))
+
+(define (random-select xs)
+  (list-ref xs (random (length xs))))
+
+(module+ main
+  (current-target 'svg)
+ 
+  (define (do-it text name)
+    (render-svg text
+                (list (list (λ () 'Black) 11)
+                      (list (λ () 'White) 9)
+                      (list (λ () 'Black) 7)
+                      (list (λ () 'White) 5)
+                      (list (λ () 'Black) 3)
+                      (list (λ () 'White) 1))
+                (/ 1 char-edge-size) name))
+
+  (do-it "P" 'pollen-raw))

pollen/app/refont.rkt

@@ -0,0 +1,145 @@
+#lang debug racket
+(require racket/gui sugar/coerce sugar/debug)
+(define current-cell-size (make-parameter 30))
+(define current-dc (make-parameter #f))
+(define current-bitmap (make-parameter #f))
+(define current-target (make-parameter 'gui))
+(define current-stroke-scale (make-parameter 1))
+(define char-edge-size 6)
+
+(define (pathify vs)
+  (define p (new dc-path%))
+  (define pts
+    (for/list ([v (in-list vs)])
+      (list (* (current-cell-size) (sub1 (modulo v 10)))
+            (* (current-cell-size) (- 4 (sub1 (floor (/ v 10))))))))
+  (send/apply p move-to (car pts))
+  (for/last ([pt (in-list (cdr pts))])
+    (send/apply p line-to pt))
+  (when (= (first vs) (last vs)) (send p close))
+  p)
+
+(struct $glyph (name paths))
+
+(define font-definition 
+  '((a (51 54 45 15 12 21 31 33))
+    (b (11 51 55 25 14 13) (35 33))
+    (c (25 15 11 41 52 55 45))
+    (d (31 11 14 25 45 54 51))
+    (e (15 11 41 52 55 35 33))
+    (E (55 52 41 11 15) (31 35))
+    (f (11 41 52 55) (31 35))
+    (g (33 35 15 11 41 52 55))
+    (h (11 51) (15 55) (31 35))
+    (i (11 15) (51 55) (13 53))
+    (j (53 55 15 12 21 31))
+    (k (11 51) (11 21 54 55) (43 34 25 15))
+    (L (51 11 15) (53 33 35))
+    (l (25 15 11 41 52))
+    (m (11 51 54 45 15) (53 13))
+    (n (11 51 54 45 15))
+    (N (11 51 52 43 23 14 15 55))
+    (O (11 41 52 55 25 14 11))
+    (o (51 54 45 15 12 21 51))
+    (P (11 51 54 45 35 24 23))
+    (p (51 54 45 35 33 13 11 31))
+    (p0 (11 51 55 35 24 23))
+    (q (33 24 13 11 41 52 55 35 24))
+    (r (11 51 53 54 45 35 33 23 14 15))
+    (s (11 14 25 35 31 41 52 55))
+    (t (31 51 55 35) (53 13) (11 15))
+    (T (51 55) (53 13))
+    (u (51 21 12 15 55))
+    (v (55 35 13 11 51))
+    (w (51 21 12 15 55) (53 13))
+    (x (51 52 43 23 14 15) (11 12 23 43 54 55))
+    (X (51 41 32 34 25 15) (11 21 32 34 45 55))
+    (y (51 31 35)(55 25 14 11))
+    (z (51 55 45 34 32 21 11 15))
+    (♥ (12 21 41 52 43 54 45 25 14 12))
+    (0 (51 54 45 15 12 21 31 51))
+    (1 (51 53 13) (11 15))
+    (2 (51 54 45 35 31 11 15))
+    (3 (51 54 45 15 11) (31 35))
+    (4 (41 21 25) (54 14))
+    (5 (55 51 31 35 25 14 11))
+    (6 (31 35 25 14 11 41 52 55))
+    (7 (51 55 45 22 12))
+    (8 (12 21 51 54 45 15 12) (31 35))
+    (9 (11 14 25 55 52 41 31 35))
+    (λ (51 52 25 15) (11 21 43))
+    (> (51 52 25 15))
+    (% (11 51) (12 52) (13 53) (14 54) (15 55))
+    (^ (11 51) (12 42) (13 33) (14 24))
+    (< (11 21 43))
+    (|(| (55 54 43 23 14 15))
+    (|)| (51 52 43 23 12 11))))
+
+
+(define glyphs (map (λ (i) ($glyph (->string (car i)) (map pathify (cdr i)))) font-definition))
+
+(define (type str [xoffset 0] [yoffset 0] #:color color-proc #:width width)
+  (send* (current-dc)
+    [set-brush "white" 'transparent]
+    [set-pen (make-pen #:color (->string (if (procedure? color-proc) (color-proc) color-proc)) #:width width #:style 'solid #:cap 'projecting #:join 'miter)])
+  (for/fold ([xoffset xoffset]
+             [yoffset yoffset])
+            ([c (in-list (string->list str))])
+    (define g (findf (λ (g) (equal? ($glyph-name g) (string c))) glyphs))
+    (when g
+      (for ([p (in-list ($glyph-paths g))])
+        (send (current-dc) draw-path p
+              (+ xoffset (current-cell-size))
+              (+ yoffset (current-cell-size)))))
+    (values (+ xoffset (* (current-cell-size) char-edge-size)) yoffset)))
+
+(define (layer-type str #:xoffset [xoffset 0] #:yoffset [yoffset 0] . attrs)
+  (for ([layer (in-list (for/list ([i (in-range 0 (length attrs) 2)])
+                          (list (list-ref attrs i) (list-ref attrs (add1 i)))))])
+    (type str xoffset yoffset #:color (first layer) #:width (* (current-cell-size) (current-stroke-scale) (second layer))))) 
+
+(define (render text layers [stroke-scale (/ 1 char-edge-size)] [name 'test])
+  (define lines (string-split text))
+  (define horiz (* (current-cell-size) (apply max (map string-length lines)) char-edge-size))
+  (define vert (* (current-cell-size) char-edge-size (length lines)))
+  (parameterize* ([current-bitmap (case (current-target)
+                                    [(svg) #false]
+                                    [else (make-bitmap horiz vert)])]
+                  [current-dc
+                   (case (current-target)
+                     [(svg) (new svg-dc%
+                                 [width horiz]
+                                 [height vert]
+                                 [output (build-path
+                                          (find-system-path 'desk-dir)
+                                          (format "~a.svg" name))]
+                                 [exists 'replace])]
+                     [else (new bitmap-dc% [bitmap (current-bitmap)])])]
+                  [current-stroke-scale stroke-scale])
+    (case (current-target)
+      [(svg) (send* (current-dc) [start-doc ""][start-page])])
+    (send (current-dc) set-smoothing 'smoothed)
+    (for* ([(line lineidx) (in-indexed lines)]
+           [layer (in-list layers)])
+      (apply layer-type line 
+             #:yoffset (* (current-cell-size) char-edge-size lineidx)
+             layer))
+    (case (current-target)
+      [(svg) (send* (current-dc) [end-page][end-doc])]
+      [(png) (send (current-bitmap) save-file (build-path
+                                               (find-system-path 'desk-dir)
+                                               (format "~a.png" name)) 'png)]
+      [(gui) (make-object image-snip% (current-bitmap))])))
+
+(define (render-svg . args)
+  (parameterize ([current-target 'svg])
+    (apply render args)))
+
+(define (render-png . args)
+  (parameterize ([current-target 'png])
+    (apply render args)))
+
+(module+ main
+  (render "PoLEn" (for/list ([color (in-cycle '(Black White))]
+                              [size (in-range 11 0 -2)])
+                     (list color size))))

pollen/info.rkt

@@ -4,6 +4,10 @@
 (define raco-commands '(("pollen" (submod pollen/private/command raco) "issue Pollen command" #f)))
 (define compile-omit-paths '("test" "tools" "server-extras" "scribblings/third-tutorial-files"))
 ;; it's redundant to test "pollen.scrbl" because it incorporates the other scribble sources by reference
-(define test-omit-paths '("test/data" "tools" "server-extras" "scribblings/third-tutorial-files" "scribblings/pollen.scrbl"))
+;; don't test app.rkt because it launches the gui
+(define test-omit-paths '("test/data" "tools" "server-extras" "scribblings/third-tutorial-files" "scribblings/pollen.scrbl" "app"))
 ;; don't put #"p" in this list because it's not a #lang
 (define module-suffixes '(#"pp" #"pm" #"pmd" #"ptree"))
+
+(define gracket-launcher-names '("Pollen"))
+(define gracket-launcher-libraries '("app/app.rkt"))

pollen/private/command.rkt

@@ -8,6 +8,7 @@
          "file-utils.rkt"
          "log.rkt"
          "../setup.rkt")
+(provide start-project-server)
 
 ;; The use of dynamic-require throughout this file is intentional:
 ;; this way, low-dependency raco commands (like "version") are faster.
@@ -44,11 +45,11 @@
     [(let ([str (getenv "PLTSTDERR")])
        (and str (regexp-match "@pollen" str))) (dispatch-thunk)]
     [else (with-logging-to-port
-           (current-error-port)
+              (current-error-port)
-           dispatch-thunk
+            dispatch-thunk
-           #:logger pollen-logger
+            #:logger pollen-logger
-           'info
+            'info
-           'pollen)]))
+            'pollen)]))
 
 (define (very-nice-path x)
   (path->complete-path (simplify-path (cleanse-path (->path x)))))
@@ -153,11 +154,22 @@ version                print the version" (current-server-port) (make-publish-di
                (when (render-with-subdirs?)
                  (for ([path (in-list dirlist)]
                        #:when (directory-exists? path))
-                      (render-one-dir (->complete-path path)))))))]
+                   (render-one-dir (->complete-path path)))))))]
         [path-args ;; path mode
          (message (format "rendering ~a" (string-join (map ->string path-args) " ")))
          (handle-batch-render path-args)]))))
 
+(define (start-project-server dir
+                              [http-port 8080]
+                              [launch-wanted #false]
+                              [localhost-wanted #false])
+  (when dir
+    (parameterize ([current-project-root dir]
+                   [current-server-port (or http-port (setup:project-server-port))]
+                   [current-server-listen-ip (and localhost-wanted "127.0.0.1")])
+      (message "starting project server ...")
+      ((dynamic-require 'pollen/private/project-server 'start-server) (format "/~a" (setup:main-pagetree dir)) launch-wanted))))
+
 (define (handle-start)
   (define launch-wanted #f)
   (define localhost-wanted #f)
@@ -176,11 +188,7 @@ version                print the version" (current-server-port) (make-publish-di
                       (string->number (cadr clargs))))
   (when (and http-port (not (exact-positive-integer? http-port)))
     (error (format "~a is not a valid port number" http-port)))
-  (parameterize ([current-project-root dir]
+  (start-project-server dir http-port launch-wanted localhost-wanted))
-                 [current-server-port (or http-port (setup:project-server-port))]
-                 [current-server-listen-ip (and localhost-wanted "127.0.0.1")])
-    (message "starting project server ...")
-    ((dynamic-require 'pollen/private/project-server 'start-server) (format "/~a" (setup:main-pagetree dir)) launch-wanted)))
 
 (define (make-publish-dir-name [project-root (current-directory)] [arg-command-name #f])
   (define user-publish-path
@@ -205,7 +213,7 @@ version                print the version" (current-server-port) (make-publish-di
     (and (>= (length xs) (length prefix))
          (andmap equal? prefix (for/list ([(x idx) (in-indexed xs)]
                                           #:break (= idx (length prefix)))
-                                         x))))
+                                 x))))
   ((explode-path possible-subdir) . has-prefix? . (explode-path possible-superdir)))
 
 (define (handle-publish)

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,16 @@
-#lang web-server/base
+#lang racket/base
 (require racket/runtime-path
+         racket/match
          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,31 +21,53 @@
 
 (define-runtime-path mime-types "server-extras/mime.types")
 
-(define (start-server servlet-path [open-browser-window? #f])
+(define (make-static-dispatcher-sequence . pths)
-  (define-values (pollen-servlet _)
+  (apply sequencer:make
-    (dispatch-rules
+         (for/list ([pth (in-list pths)])
-     [((string-arg) ... (? (λ (x) (string=? "" x)))) route-index] ; last element of a "/"-terminated url is ""
+           (files:make
-     [((string-arg) ... (? pagetree-source?)) route-dashboard]
+            #:path->mime-type (make-path->mime-type mime-types)
-     [((string-arg) ... "in" (string-arg) ...) route-in]
+            #:url->path (make-url->path (path->string pth))))))
-     [((string-arg) ... "out" (string-arg) ...) route-out]
+
-     [else route-default]))
+(define-values (pollen-servlet _)
+  (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 (let ([clsi (current-server-listen-ip)])
+             (if clsi
+                 (format "project server permitting access only to ~a"
+                         (case clsi
+                           [("127.0.0.1") "localhost"]
+                           [else clsi]))
+                 "project server permitting access to all clients")))
   (message "ready to rock")
   
-  (parameterize ([error-print-width 1000])
+  (define stop-func
-    (serve/servlet pollen-servlet
+    (parameterize ([error-print-width 1000])
-                   #:launch-browser? open-browser-window?
+      (serve
-                   #:servlet-path servlet-path
+       #:dispatch (sequencer:make
-                   #:port (current-server-port)
+                   (dispatch/servlet pollen-servlet)
-                   #:listen-ip (current-server-listen-ip)
+                   (make-static-dispatcher-sequence
-                   #:servlet-regexp #rx"" ; respond to top level
+                    (current-project-root)
-                   #:command-line? #true
+                    (current-server-extras-path))
-                   #:file-not-found-responder route-404
+                   (dispatch/servlet route-404))
-                   #:mime-types-path mime-types
+       #:listen-ip (current-server-listen-ip)
-                   #:extra-files-paths (list (current-server-extras-path) (current-project-root)))))
+       #:port (current-server-port))))
+  (when open-browser-window?
+    (send-url (string-append server-name servlet-path)))
+  (if return?
+      stop-func
+      (with-handlers ([exn:break? (λ (e) (stop-func) (message "project server stopped"))])
+        (do-not-return))))