From fb44ea118e388a6ea282700f41ed353d10d09f69 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 19 Apr 2020 22:03:37 -0700 Subject: [PATCH] hack it --- pollen/app.rkt | 45 +++++++------- pollen/private/project-server-routes.rkt | 7 ++- pollen/private/project-server.rkt | 79 ++++++++++++++---------- 3 files changed, 74 insertions(+), 57 deletions(-) diff --git a/pollen/app.rkt b/pollen/app.rkt index 423d829..0822c68 100644 --- a/pollen/app.rkt +++ b/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) - [#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 (setup:main-pagetree dir) #:serve-only #true)) - (thread-send cthd stop))))) - (current-server-stopper (thread-receive))]))])) + (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% @@ -147,9 +147,14 @@ [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]))])) + (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% @@ -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") - (sleep 0))))) - + (send status-box-ed insert "\n"))))) (send window show #t) diff --git a/pollen/private/project-server-routes.rkt b/pollen/private/project-server-routes.rkt index ec1c19d..928259a 100644 --- a/pollen/private/project-server-routes.rkt +++ b/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 (format "from ~a" client)])))) + [client #:when (not (member client localhost-names)) + (format "from ~a" client)] + [_ ""])))) ;; pass string args to route, then ;; package route into right format for web server diff --git a/pollen/private/project-server.rkt b/pollen/private/project-server.rkt index 1cbf0dd..c70b8fc 100755 --- a/pollen/private/project-server.rkt +++ b/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] - #: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 "" - [((string-arg) ... (? pagetree-source?)) route-dashboard] - [((string-arg) ... "in" (string-arg) ...) route-in] - [((string-arg) ... "out" (string-arg) ...) route-out] - [else route-default])) +(define (make-static-dispatcher-sequence . pths) + (apply sequencer:make + (for/list ([pth (in-list pths)]) + (files:make + #:path->mime-type (make-path->mime-type mime-types) + #:url->path (make-url->path (path->string pth)))))) + +(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 (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 - [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 + + (define stop-func + (parameterize ([error-print-width 1000]) + (serve + #:dispatch (sequencer:make + (dispatch/servlet pollen-servlet) + (make-static-dispatcher-sequence + (current-project-root) + (current-server-extras-path)) + (dispatch/servlet route-404)) + #:listen-ip (current-server-listen-ip) + #: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)))) \ No newline at end of file