From fd3a3cd38ba098c9720e4b361abfcdf1956620d8 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 18 Apr 2020 13:10:24 -0700 Subject: [PATCH] app harder --- pollen/app.rkt | 143 +++++++++++++++++++++++------- pollen/private/project-server.rkt | 42 ++++++--- 2 files changed, 142 insertions(+), 43 deletions(-) diff --git a/pollen/app.rkt b/pollen/app.rkt index 753a97a..9ec87e6 100644 --- a/pollen/app.rkt +++ b/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) diff --git a/pollen/private/project-server.rkt b/pollen/private/project-server.rkt index 92ff3ab..1cbf0dd 100755 --- a/pollen/private/project-server.rkt +++ b/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))))) \ No newline at end of file + + (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))))])) \ No newline at end of file