make parent row navigation for dashboard

pull/9/head
Matthew Butterick 11 years ago
parent 414518af4f
commit 02c98719e8

@ -45,6 +45,25 @@
(check-false (directory-pathish? "foobarzooblish"))) (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 ;; helper function for ptree
;; make paths absolute to test whether files exist, ;; make paths absolute to test whether files exist,
;; then convert back to relative ;; then convert back to relative

@ -13,10 +13,6 @@ table {
width: 100%; width: 100%;
} }
table:before {
content: "Pollen dashboard";
}
tr > td:first-child + td { tr > td:first-child + td {
font-family: "Triplicate T4"; font-family: "Triplicate T4";
@ -28,7 +24,7 @@ tr, tr + tr {
} }
td { td {
font-size: 20px; font-size: 17px;
width: 20%; width: 20%;
} }
@ -45,4 +41,11 @@ a {
a:active { a:active {
text-decoration: underline; text-decoration: underline;
}
tt {
font-family: "AlixFB";
font-size: 100%;
white-space: pre;
word-wrap: normal;
} }

@ -1,9 +1,9 @@
#lang racket/base #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 web-server/http/xexpr web-server/dispatchers/dispatch)
(require (only-in net/url url-query url->path url->string)) (require net/url)
(require (only-in web-server/http/request-structs request-uri request-client-ip request?)) (require web-server/http/request-structs)
(require (only-in web-server/http/response-structs response?)) (require web-server/http/response-structs)
(require "world.rkt" "render.rkt" "readability.rkt" "predicates.rkt" "debug.rkt") (require "world.rkt" "render.rkt" "readability.rkt" "predicates.rkt" "debug.rkt")
(module+ test (require rackunit)) (module+ test (require rackunit))
@ -14,17 +14,37 @@
(provide route-dashboard route-raw route-xexpr route-default route-404) (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 client (request-client-ip req))
(define url-string (url->string (request-uri req))) (define url-string (url->string (request-uri req)))
(message "Request:" (string-replace url-string DASHBOARD_NAME " dashboard") (message "Request:" (string-replace url-string DASHBOARD_NAME " dashboard")
"from" (if (equal? client "::1") "localhost" client))) "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) (define/contract (route-wrapper route-proc)
(procedure? . -> . procedure?) (procedure? . -> . procedure?)
(λ(req . string-args) (λ(req . string-args)
(logger req) (logger req)
(message string-args)
(define path (apply build-path PROJECT_ROOT (flatten string-args))) (define path (apply build-path PROJECT_ROOT (flatten string-args)))
(response/xexpr (route-proc path)))) (response/xexpr (route-proc path))))
@ -56,19 +76,11 @@
;; takes either a string or an xexpr ;; takes either a string or an xexpr
(define/contract (format-as-code x) (define/contract (format-as-code x)
(xexpr? . -> . tagged-xexpr?) (xexpr? . -> . tagged-xexpr?)
`(div ((style "white-space:pre-wrap;font-family:AlixFB,monospaced")) ,x)) (html-wrapper `(tt ,x)))
(module+ test
(check-equal? (format-as-code '(p "foo")) '(div ((style "white-space:pre-wrap;font-family:AlixFB,monospaced")) (p "foo"))))
;; server routes ;; server routes
;; these all produce an xexpr, which is handled upstream by response/xexpr ;; 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 ;; server route that returns raw html, formatted as code
;; for viewing source without using "view source" ;; for viewing source without using "view source"
@ -76,14 +88,15 @@
(complete-path? . -> . xexpr?) (complete-path? . -> . xexpr?)
(format-as-code (slurp path #:render #f))) (format-as-code (slurp path #:render #f)))
;; server route that returns xexpr (before conversion to html) (define route-raw (route-wrapper raw))
(define/contract (xexpr path)
(complete-path? . -> . xexpr?)
(format-as-code (~v (file->xexpr path))))
;; dashboard route
(define (dashboard dashfile) (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 empty-cell (cons #f #f))
(define (make-link-cell href+text) (define (make-link-cell href+text)
(match-define (cons href text) href+text) (match-define (cons href text) href+text)
@ -91,26 +104,39 @@
(if href (if href
`(a ((href ,href)) ,text) `(a ((href ,href)) ,text)
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 (make-path-row fn)
(define filename (->string fn)) (define filename (->string fn))
(define (file-in-dir? fn) (file-exists? (build-path dir 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)))) (define source (and (not (empty? possible-sources)) (->string (car possible-sources))))
`(tr ,@(map make-link-cell `(tr ,@(map make-link-cell
(append (list (append (list
;; folder traversal cell ;; folder traversal cell
(if (directory-exists? (build-path dir filename)) ; links subdir to its dashboard (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) empty-cell)
(cons filename filename) ; main cell (cons filename filename) ; main cell
(if source ; source cell (if needed) (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) empty-cell)
(cond ; raw cell (if needed) (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)")] [(has-binary-ext? filename) (cons #f "(binary)")]
[else (cons (format "raw/~a" filename) "output")])) [else (cons (format "raw/~a" filename) "output")]))
(if source (if source
(list (list
(if (has-ext? source POLLEN_DECODER_EXT) ; xexpr cell for pollen decoder files (if (has-ext? source POLLEN_DECODER_EXT) ; xexpr cell for pollen decoder files
@ -118,33 +144,34 @@
empty-cell)) empty-cell))
(make-list 1 empty-cell)))))) (make-list 1 empty-cell))))))
(define (unique-sorted-output-paths xs)
(sort (set->list (list->set (map ->output-path xs))) #:key ->string string<?))
(define (ineligible-path? x) (or (not (visible? x)) (member x RESERVED_PATHS))) (define (ineligible-path? x) (or (not (visible? x)) (member x RESERVED_PATHS)))
(define project-paths (filter-not ineligible-path? (directory-list dir))) (define project-paths (filter-not ineligible-path? (directory-list dir)))
;; todo: add link to parent directory (define (unique-sorted-output-paths xs)
`(html (sort (set->list (list->set (map ->output-path xs))) #:key ->string string<?))
(head (link ((rel "stylesheet") (type "text/css") (href "/poldash.css"))))
(body (html-wrapper
(table `(body
,@(map make-path-row (unique-sorted-output-paths project-paths)))))) ,(filter-not void?
`(table
,(when parent-dir (make-parent-row))
,@(map make-path-row (unique-sorted-output-paths project-paths)))))))
(define route-dashboard (route-wrapper dashboard))
(define (get-query-value url key) (define (get-query-value url key)
; query is parsed as list of pairs, key is symbol, value is string ; query is parsed as list of pairs, key is symbol, value is string
; '((key . "value") ... ) ; '((key . "value") ... )
(let ([result (memf (λ(x) (equal? (car x) key)) (url-query url))]) (let ([result (memf (λ(x) (equal? (car x) key)) (url-query url))])
(and result (cdar result)))) ; second value of first result (and result (cdar result))))
(define/contract (req->path req) (define/contract (req->path req)
(request? . -> . path?) (request? . -> . path?)
(reroot-path (url->path (request-uri req)) PROJECT_ROOT)) (reroot-path (url->path (request-uri req)) PROJECT_ROOT))
; default route ;; default route
(define (route-default req) (define (route-default req)
(logger req) (logger req)
(define force (equal? (get-query-value (request-uri req) 'force) "true")) (define force (equal? (get-query-value (request-uri req) 'force) "true"))
@ -153,8 +180,7 @@
(next-dispatcher)) (next-dispatcher))
;; error route
; error route
(define/contract (route-404 req) (define/contract (route-404 req)
(request? . -> . response?) (request? . -> . response?)
(define error-text (format "Can't find ~a" (->string (req->path req)))) (define error-text (format "Can't find ~a" (->string (req->path req))))
@ -163,9 +189,15 @@
(response/xexpr `(html ,error-text))) (response/xexpr `(html ,error-text)))
(define route-dashboard (route-wrapper dashboard)) ;; server route that returns xexpr (before conversion to html)
(define route-raw (route-wrapper raw)) (define/contract (xexpr path)
(complete-path? . -> . xexpr?)
(format-as-code (~v (file->xexpr path))))
(define route-xexpr (route-wrapper xexpr)) (define route-xexpr (route-wrapper xexpr))
(module+ main (module+ main
) (parameterize ([current-directory (build-path (current-directory) "foobar")])
(reset-project-root)
(message PROJECT_ROOT)
(dashboard (build-path "poldash.html"))))

@ -47,10 +47,12 @@
(define PROJECT_ROOT (current-directory)) (define PROJECT_ROOT (current-directory))
(define (reset-project-root) (set! PROJECT_ROOT (current-directory)))
;; use current-contract-region to calculate containing directory of module ;; 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 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_EXTRAS_DIR (build-path MODULE_ROOT "pollen-server-extras"))
(define SERVER_PORT 8088) (define SERVER_PORT 8088)
(define DASHBOARD_NAME "poldash.html") (define DASHBOARD_NAME "poldash.html")
(define DASHBOARD_CSS "poldash.css")
Loading…
Cancel
Save