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")))
;; 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

@ -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;
}

@ -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 string<?))
(define (ineligible-path? x) (or (not (visible? x)) (member x RESERVED_PATHS)))
(define project-paths (filter-not ineligible-path? (directory-list dir)))
;; todo: add link to parent directory
`(html
(head (link ((rel "stylesheet") (type "text/css") (href "/poldash.css"))))
(body
(table
,@(map make-path-row (unique-sorted-output-paths project-paths))))))
(define (unique-sorted-output-paths xs)
(sort (set->list (list->set (map ->output-path xs))) #:key ->string string<?))
(html-wrapper
`(body
,(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)
; query is parsed as list of pairs, key is symbol, value is string
; '((key . "value") ... )
(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)
(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
)
(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 (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")
(define DASHBOARD_NAME "poldash.html")
(define DASHBOARD_CSS "poldash.css")
Loading…
Cancel
Save