From 02c98719e8cd9d7873e27d092b45da01bd198ba0 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 27 Jan 2014 15:15:16 -0800 Subject: [PATCH] make parent row navigation for dashboard --- file-tools.rkt | 19 +++++ pollen-server-extras/poldash.css | 13 ++-- server-routes.rkt | 120 +++++++++++++++++++------------ world.rkt | 4 +- 4 files changed, 106 insertions(+), 50 deletions(-) diff --git a/file-tools.rkt b/file-tools.rkt index adf5867..4db2554 100644 --- a/file-tools.rkt +++ b/file-tools.rkt @@ -45,6 +45,25 @@ (check-false (directory-pathish? "foobarzooblish"))) +;; compare directories by their exploded path elements, +;; not by equal?, which will give wrong result if no slash on the end +(define/contract (directories-equal? dirx diry) + (pathish? pathish? . -> . boolean?) + (equal? (explode-path (->path dirx)) (explode-path (->path diry)))) + +(module+ test + (check-true (directories-equal? "/Users/MB/foo" "/Users/MB/foo/")) + (check-false (directories-equal? "/Users/MB/foo" "Users/MB/foo"))) + +(define (get-enclosing-dir p) + (pathish? . -> . path?) + (simplify-path (build-path (->path p) 'up))) + +(module+ test + (check-equal? (get-enclosing-dir "/Users/MB/foo.txt") (->path "/Users/MB/")) + (check-equal? (get-enclosing-dir "/Users/MB/foo/") (->path "/Users/MB/"))) + + ;; helper function for ptree ;; make paths absolute to test whether files exist, ;; then convert back to relative diff --git a/pollen-server-extras/poldash.css b/pollen-server-extras/poldash.css index 21fb7dc..e66e378 100644 --- a/pollen-server-extras/poldash.css +++ b/pollen-server-extras/poldash.css @@ -13,10 +13,6 @@ table { width: 100%; } -table:before { - content: "Pollen dashboard"; -} - tr > td:first-child + td { font-family: "Triplicate T4"; @@ -28,7 +24,7 @@ tr, tr + tr { } td { - font-size: 20px; + font-size: 17px; width: 20%; } @@ -45,4 +41,11 @@ a { a:active { text-decoration: underline; +} + +tt { + font-family: "AlixFB"; + font-size: 100%; + white-space: pre; + word-wrap: normal; } \ No newline at end of file diff --git a/server-routes.rkt b/server-routes.rkt index b802549..97cd68c 100644 --- a/server-routes.rkt +++ b/server-routes.rkt @@ -1,9 +1,9 @@ #lang racket/base -(require racket/list racket/contract racket/rerequire racket/file racket/format xml racket/match racket/set racket/string) +(require racket/list racket/contract racket/rerequire racket/file racket/format xml racket/match racket/set racket/string racket/promise racket/path) (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?)) +(require net/url) +(require web-server/http/request-structs) +(require web-server/http/response-structs) (require "world.rkt" "render.rkt" "readability.rkt" "predicates.rkt" "debug.rkt") (module+ test (require rackunit)) @@ -14,17 +14,37 @@ (provide route-dashboard route-raw route-xexpr route-default route-404) -(define (logger req) +(define (html-wrapper body-xexpr) + `(html + (head + (meta ((charset "UTF-8"))) + (link ((rel "stylesheet") + (type "text/css") + (href ,(format "/~a" DASHBOARD_CSS))))) + ,body-xexpr)) + +;; to make dummy requests for debugging +(define/contract (string->request u) + (string? . -> . request?) + (make-request #"GET" (string->url u) empty + (delay empty) #f "1.2.3.4" 80 "4.3.2.1")) + +;; print message to console about a request +(define/contract (logger req) + (request? . -> . void?) (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))) +;; pass string args to route, then +;; package route into right format for web server +;; todo: fix inbound contrfact to be proc with (path? . -> . xexpr?) +;; todo: fix outbound contract to be proc with (request? #:rest args . -> . response?) (define/contract (route-wrapper route-proc) (procedure? . -> . procedure?) (λ(req . string-args) (logger req) - (message string-args) (define path (apply build-path PROJECT_ROOT (flatten string-args))) (response/xexpr (route-proc path)))) @@ -56,19 +76,11 @@ ;; takes either a string or an xexpr (define/contract (format-as-code x) (xexpr? . -> . tagged-xexpr?) - `(div ((style "white-space:pre-wrap;font-family:AlixFB,monospaced")) ,x)) - -(module+ test - (check-equal? (format-as-code '(p "foo")) '(div ((style "white-space:pre-wrap;font-family:AlixFB,monospaced")) (p "foo")))) + (html-wrapper `(tt ,x))) ;; server routes ;; these all produce an xexpr, which is handled upstream by response/xexpr -;; server route that returns html -;; todo: what is this for? -(define/contract (route-html path) - (complete-path? . -> . xexpr?) - (file->xexpr path)) ;; server route that returns raw html, formatted as code ;; for viewing source without using "view source" @@ -76,14 +88,15 @@ (complete-path? . -> . xexpr?) (format-as-code (slurp path #:render #f))) -;; server route that returns xexpr (before conversion to html) -(define/contract (xexpr path) - (complete-path? . -> . xexpr?) - (format-as-code (~v (file->xexpr path)))) +(define route-raw (route-wrapper raw)) +;; dashboard route (define (dashboard dashfile) - (define dir (apply build-path (drop-right (explode-path dashfile) 1))) + (define dir (get-enclosing-dir dashfile)) + (define (in-project-root?) + (directories-equal? dir PROJECT_ROOT)) + (define parent-dir (and (not (in-project-root?)) (get-enclosing-dir dir))) (define empty-cell (cons #f #f)) (define (make-link-cell href+text) (match-define (cons href text) href+text) @@ -91,26 +104,39 @@ (if href `(a ((href ,href)) ,text) text))))) + (define (make-parent-row) + (define url-to-parent-dashboard (format "/~a" (find-relative-path PROJECT_ROOT (build-path parent-dir DASHBOARD_NAME)))) + (define url-to-parent (string-replace url-to-parent-dashboard DASHBOARD_NAME "")) + + `(tr ,@(map make-link-cell (list + (cons url-to-parent-dashboard "←") + (cons url-to-parent url-to-parent) + empty-cell + (cons #f "(parent dir)") + empty-cell)))) + (define (make-path-row fn) (define filename (->string fn)) (define (file-in-dir? fn) (file-exists? (build-path dir fn))) - (define possible-sources (filter file-in-dir? (list (->preproc-source-path filename) (->pollen-source-path filename)))) + (define possible-sources + (if (directory-exists? fn) + empty ;; folders don't have source files + (filter file-in-dir? (list (->preproc-source-path filename) (->pollen-source-path filename))))) (define source (and (not (empty? possible-sources)) (->string (car possible-sources)))) `(tr ,@(map make-link-cell - (append (list + (append (list ;; folder traversal cell (if (directory-exists? (build-path dir filename)) ; links subdir to its dashboard - (cons (format "~a/~a" filename DASHBOARD_NAME) "dash") + (cons (format "~a/~a" filename DASHBOARD_NAME) "→") empty-cell) - (cons filename filename) ; main cell + (cons filename filename) ; main cell (if source ; source cell (if needed) - (cons source (format "~a source" (get-ext source))) + (cons (format "raw/~a" source) (format "~a source" (get-ext source))) empty-cell) (cond ; raw cell (if needed) - [(directory-exists? (build-path dir filename)) (cons #f "(folder)")] + [(directory-exists? (build-path dir filename)) (cons #f "(subdir)")] [(has-binary-ext? filename) (cons #f "(binary)")] [else (cons (format "raw/~a" filename) "output")])) - (if source (list (if (has-ext? source POLLEN_DECODER_EXT) ; xexpr cell for pollen decoder files @@ -118,33 +144,34 @@ empty-cell)) (make-list 1 empty-cell)))))) - (define (unique-sorted-output-paths xs) - (sort (set->list (list->set (map ->output-path xs))) #:key ->string stringlist (list->set (map ->output-path xs))) #:key ->string stringpath req) (request? . -> . path?) (reroot-path (url->path (request-uri req)) PROJECT_ROOT)) -; default route +;; default route (define (route-default req) (logger req) (define force (equal? (get-query-value (request-uri req) 'force) "true")) @@ -153,8 +180,7 @@ (next-dispatcher)) - -; error route +;; error route (define/contract (route-404 req) (request? . -> . response?) (define error-text (format "Can't find ~a" (->string (req->path req)))) @@ -163,9 +189,15 @@ (response/xexpr `(html ,error-text))) -(define route-dashboard (route-wrapper dashboard)) -(define route-raw (route-wrapper raw)) +;; server route that returns xexpr (before conversion to html) +(define/contract (xexpr path) + (complete-path? . -> . xexpr?) + (format-as-code (~v (file->xexpr path)))) + (define route-xexpr (route-wrapper xexpr)) (module+ main - ) \ No newline at end of file + (parameterize ([current-directory (build-path (current-directory) "foobar")]) + (reset-project-root) + (message PROJECT_ROOT) + (dashboard (build-path "poldash.html")))) \ No newline at end of file diff --git a/world.rkt b/world.rkt index 2bebfb6..e70b8a6 100644 --- a/world.rkt +++ b/world.rkt @@ -47,10 +47,12 @@ (define PROJECT_ROOT (current-directory)) +(define (reset-project-root) (set! PROJECT_ROOT (current-directory))) ;; use current-contract-region to calculate containing directory of module (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 +(define DASHBOARD_NAME "poldash.html") +(define DASHBOARD_CSS "poldash.css") \ No newline at end of file