diff --git a/server-routes.rkt b/server-routes.rkt index 1cae40f..20a6fc0 100644 --- a/server-routes.rkt +++ b/server-routes.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require racket/list racket/contract racket/rerequire racket/file racket/format xml racket/match racket/set) -(require web-server/http/xexpr) +(require racket/list racket/contract racket/rerequire racket/file racket/format xml racket/match racket/set racket/string) +(require web-server/http/xexpr web-server/dispatchers/dispatch) (require (only-in net/url url-query url->path url->string)) (require (only-in web-server/http/request-structs request-uri request-client-ip request?)) (require (only-in web-server/http/response-structs response?)) @@ -12,7 +12,21 @@ ;;; separated out for ease of testing ;;; because it's tedious to start the server just to check a route. -(provide (all-defined-out)) +(provide route-dashboard route-raw route-xexpr route-default route-404) + +(define (logger req) + (define client (request-client-ip req)) + (define url-string (url->string (request-uri req))) + (message "Request:" (string-replace url-string DASHBOARD_NAME " dashboard") + "from" (if (equal? client "::1") "localhost" client))) + +(define/contract (route-wrapper route-proc) + (procedure? . -> . procedure?) + (λ(req . string-args) + (logger req) + (define path (apply build-path PROJECT_ROOT (flatten string-args))) + (response/xexpr (route-proc path)))) + ;; extract main xexpr from a path (define/contract (file->xexpr path #:render [wants-render #t]) @@ -57,19 +71,17 @@ ;; server route that returns raw html, formatted as code ;; for viewing source without using "view source" -(define/contract (route-raw path) +(define/contract (raw path) (complete-path? . -> . xexpr?) (format-as-code (slurp path #:render #f))) ;; server route that returns xexpr (before conversion to html) -(define/contract (route-xexpr path) +(define/contract (xexpr path) (complete-path? . -> . xexpr?) (format-as-code (~v (file->xexpr path)))) - - -(define (route-dashboard dir) +(define (dashboard dir) (define empty-cell (cons #f #f)) (define (make-link-cell href+text) (match-define (cons href text) href+text) @@ -133,9 +145,12 @@ ; default route (define (route-default req) + (logger req) (define force (equal? (get-query-value (request-uri req) 'force) "true")) (with-handlers ([exn:fail? (λ(e) (message "Render is skipping" (url->string (request-uri req)) "because of error\n" (exn-message e)))]) - (render (req->path req) #:force force))) + (render (req->path req) #:force force)) + (next-dispatcher)) + ; error route @@ -146,5 +161,10 @@ ;`(html ,(slurp (build-path SERVER_EXTRAS_DIR "404.html"))) (response/xexpr `(html ,error-text))) + +(define route-dashboard (route-wrapper dashboard)) +(define route-raw (route-wrapper raw)) +(define route-xexpr (route-wrapper xexpr)) + (module+ main - (route-dashboard "foobar")) \ No newline at end of file + ) \ No newline at end of file diff --git a/server.rkt b/server.rkt index 9d23329..1cc2d17 100755 --- a/server.rkt +++ b/server.rkt @@ -1,51 +1,30 @@ #lang web-server -(require "startup.rkt") -(require web-server/servlet-env web-server/dispatch web-server/dispatchers/dispatch web-server/configuration/responders xml) -(require "server-routes.rkt" "debug.rkt" "world.rkt") +(require web-server/servlet-env + web-server/dispatch) +(require "server-routes.rkt" + "debug.rkt" + "world.rkt") -(define port-number 8088) - -(message (format "Project root is ~a" PROJECT_ROOT)) -(message (format "Project server is http://localhost:~a" port-number) "(Ctrl-C to exit)") - -(define (logger req) - (define client (request-client-ip req)) - (define url-string (url->string (request-uri req))) - (message "Request:" (string-replace url-string DASHBOARD_NAME " dashboard") - "from" (if (equal? client "::1") "localhost" client))) - -(define/contract (route-wrapper route-proc) - (procedure? . -> . procedure?) - (λ(req . string-args) - (logger req) - (define path (apply build-path PROJECT_ROOT (flatten string-args))) - (response/xexpr (route-proc path)))) - -(define-values (start url) +(define-values (pollen-servlet url) (dispatch-rules - ;; the match patterns for each rule represent /each/slashed/piece of a url - ;; (as if the url is split on slashes into a list before matching) - ;; dashboard page: works on any url of form /dir/dir/dir/poldash.html ;; todo: figure out how to use world:DASHBOARD_NAME here - [((string-arg) ... "poldash.html") (route-wrapper route-dashboard)] - ;; raw viewer: works on any url of form /dir/dir/raw/name.html - ;; (pattern matcher automatically takes out the "raw") - [((string-arg) ... "raw" (string-arg)) (route-wrapper route-raw)] - [((string-arg) ... "xexpr" (string-arg)) (route-wrapper route-xexpr)] - ; [((string-arg) ... "force" (string-arg)) (route-wrapper route-force)] - [else (λ(req) - ;; because it's the "else" route, can't use string-arg matcher - (logger req) - (route-default req) - (next-dispatcher))])) + [((string-arg) ... "poldash.html") route-dashboard] + [((string-arg) ... "raw" (string-arg)) route-raw] + [((string-arg) ... "xexpr" (string-arg)) route-xexpr] + ;; [((string-arg) ... "force" (string-arg)) (route-wrapper route-force)] + [else route-default])) -(message (format "Project dashboard is http://localhost:~a/pollen.html" port-number)) -(message "Ready to rock") +(message (format "Welcome to Pollen ~a" POLLEN_VERSION) (format "(Racket ~a)" (version))) +(message (format "Project root is ~a" PROJECT_ROOT)) +(define server-name (format "http://localhost:~a" SERVER_PORT)) +(message (format "Project server is ~a" server-name) "(Ctrl-C to exit)") +(message (format "Project dashboard is ~a/pollen.html" server-name)) +(message "Ready to rock") -(serve/servlet start - #:port port-number +(serve/servlet pollen-servlet + #:port SERVER_PORT #:listen-ip #f #:servlet-regexp #rx"" ; respond to top level #:command-line? #t diff --git a/startup.rkt b/startup.rkt index 0248941..e69de29 100644 --- a/startup.rkt +++ b/startup.rkt @@ -1,3 +0,0 @@ -#lang racket/base -(require "debug.rkt" "world.rkt") -(message (format "Welcome to Pollen ~a" POLLEN_VERSION) (format "(Racket ~a)" (version))) diff --git a/world.rkt b/world.rkt index 282b84d..2bebfb6 100644 --- a/world.rkt +++ b/world.rkt @@ -51,4 +51,6 @@ (define MODULE_ROOT (apply build-path (drop-right (explode-path (current-contract-region)) 1))) (define SERVER_EXTRAS_DIR (build-path MODULE_ROOT "pollen-server-extras")) +(define SERVER_PORT 8088) + (define DASHBOARD_NAME "poldash.html") \ No newline at end of file