mbutterick
/
pollen
3
3
Fork 0
Code Issues 1 Pull Requests Projects Releases Wiki Activity

make dashboard HTML standards-compliant by adding DOCTYPE and <title> element (closes #23)

Browse Source
pull/27/head
Matthew Butterick 10 years ago
parent dba97e6fd1
commit 451370c7e5
1 changed files with 45 additions and 41 deletions
Show Stats Download Patch File Download Diff File

86
server-routes.rkt
Unescape Escape View File

@ -15,9 +15,13 @@
(provide route-dashboard route-xexpr route-default route-404 route-in route-out) (provide route-dashboard route-xexpr route-default route-404 route-in route-out)
(define (body-wrapper content-xexpr) (define (response/xexpr+doctype xexpr)
(response/xexpr #:preamble #"<!DOCTYPE html>" xexpr))
(define (body-wrapper content-xexpr #:title [title #f])
`(html `(html
(head (head
(title ,(if title title "Pollen"))
(meta ([charset "UTF-8"])) (meta ([charset "UTF-8"]))
(link ([rel "stylesheet"] (link ([rel "stylesheet"]
[type "text/css"] [type "text/css"]
@ -29,7 +33,7 @@
(define/contract (string->request u) (define/contract (string->request u)
(string? . -> . request?) (string? . -> . request?)
(make-request #"GET" (string->url u) empty (make-request #"GET" (string->url u) empty
(delay empty) #f "1.2.3.4" 80 "4.3.2.1")) (delay empty) #f "1.2.3.4" 80 "4.3.2.1"))
;; print message to console about a request ;; print message to console about a request
(define/contract (logger req) (define/contract (logger req)
@ -38,7 +42,7 @@
(define localhost-client "::1") (define localhost-client "::1")
(define url-string (url->string (request-uri req))) (define url-string (url->string (request-uri req)))
(message "request:" (string-replace url-string world:default-pagetree " dashboard") (message "request:" (string-replace url-string world:default-pagetree " dashboard")
(if (not (equal? client localhost-client)) (format "from ~a" client) ""))) (if (not (equal? client localhost-client)) (format "from ~a" client) "")))
;; pass string args to route, then ;; pass string args to route, then
;; package route into right format for web server ;; package route into right format for web server
@ -49,7 +53,7 @@
(λ(req . string-args) (λ(req . string-args)
(logger req) (logger req)
(define path (apply build-path (world:current-project-root) (flatten string-args))) (define path (apply build-path (world:current-project-root) (flatten string-args)))
(response/xexpr (route-proc path)))) (response/xexpr+doctype (route-proc path))))
;; extract main xexpr from a path ;; extract main xexpr from a path
@ -89,8 +93,8 @@
(p "filename =" ,(->string relative-path)) (p "filename =" ,(->string relative-path))
(p "size = " ,(bytecount->string (file-size path))) (p "size = " ,(bytecount->string (file-size path)))
,@(when/splice (not (equal? (get-ext path) "svg")) ,@(when/splice (not (equal? (get-ext path) "svg"))
`(p "width = " ,(->string (image-width img)) " " `(p "width = " ,(->string (image-width img)) " "
"height = " ,(->string (image-height img)))) "height = " ,(->string (image-height img))))
(a ((href ,img-url)) (img ((style "width:100%;border:1px solid #eee")(src ,img-url)))))) (a ((href ,img-url)) (img ((style "width:100%;border:1px solid #eee")(src ,img-url))))))
(require file/unzip) (require file/unzip)
@ -145,17 +149,17 @@
(match-define (cons href text) href+text) (match-define (cons href text) href+text)
(filter-not void? `(td ,(when text (filter-not void? `(td ,(when text
(if href (if href
`(a ((href ,href)) ,text) `(a ((href ,href)) ,text)
text))))) text)))))
(define (make-parent-row) (define (make-parent-row)
(define title (string-append "Project root" (if (equal? (world:current-project-root) dashboard-dir) (format " = ~a" dashboard-dir) ""))) (define title (string-append "Project root" (if (equal? (world:current-project-root) dashboard-dir) (format " = ~a" dashboard-dir) "")))
(define dirs (cons title (if (not (equal? (world:current-project-root) dashboard-dir)) (define dirs (cons title (if (not (equal? (world:current-project-root) dashboard-dir))
(explode-path (find-relative-path (world:current-project-root) dashboard-dir)) (explode-path (find-relative-path (world:current-project-root) dashboard-dir))
null))) null)))
(define dirlinks (cons "/" (map (λ(ps) (format "/~a/" (apply build-path ps))) (define dirlinks (cons "/" (map (λ(ps) (format "/~a/" (apply build-path ps)))
(for/list ([i (in-range (length (cdr dirs)))]) (for/list ([i (in-range (length (cdr dirs)))])
(take (cdr dirs) (add1 i)))))) (take (cdr dirs) (add1 i))))))
`(tr (th ((colspan "3")) ,@(add-between (map (λ(dir dirlink) `(a ((href ,(format "~a~a" dirlink world:default-pagetree))) ,(->string dir))) dirs dirlinks) "/")))) `(tr (th ((colspan "3")) ,@(add-between (map (λ(dir dirlink) `(a ((href ,(format "~a~a" dirlink world:default-pagetree))) ,(->string dir))) dirs dirlinks) "/"))))
(define (make-path-row filename-path) (define (make-path-row filename-path)
@ -163,39 +167,39 @@
(define possible-source (->source-path (build-path dashboard-dir filename-path))) (define possible-source (->source-path (build-path dashboard-dir filename-path)))
(define source (and possible-source (->string (find-relative-path dashboard-dir possible-source)))) (define source (and possible-source (->string (find-relative-path dashboard-dir possible-source))))
`(tr ,@(map make-link-cell `(tr ,@(map make-link-cell
(append (list (append (list
(cond ; main cell (cond ; main cell
[(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard [(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard
(cons (format "~a/~a" filename world:default-pagetree) (format "~a/" filename))] (cons (format "~a/~a" filename world:default-pagetree) (format "~a/" filename))]
[(and source (equal? (get-ext source) "scrbl")) [(and source (equal? (get-ext source) "scrbl"))
(cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))] (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))]
[source (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) "." ,(get-ext source))))] [source (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) "." ,(get-ext source))))]
[else (cons filename filename)]) [else (cons filename filename)])
(cond ; in cell (cond ; in cell
[source (cons (format "in/~a" source) "in")] [source (cons (format "in/~a" source) "in")]
[(or (pagetree-source? filename) (sourceish? filename)) (cons (format "in/~a" filename) "in")] [(or (pagetree-source? filename) (sourceish? filename)) (cons (format "in/~a" filename) "in")]
[else empty-cell]) [else empty-cell])
(cond ; out cell (cond ; out cell
[(directory-exists? (build-path dashboard-dir filename)) (cons #f #f)] [(directory-exists? (build-path dashboard-dir filename)) (cons #f #f)]
[(pagetree-source? filename) empty-cell] [(pagetree-source? filename) empty-cell]
[else (cons (format "out/~a" filename) "out")])))))) [else (cons (format "out/~a" filename) "out")]))))))
(define (ineligible-path? x) (member x world:paths-excluded-from-dashboard)) (define (ineligible-path? x) (member x world:paths-excluded-from-dashboard))
(define project-paths (define project-paths
(filter-not ineligible-path? (map ->path (pagetree->list (filter-not ineligible-path? (map ->path (pagetree->list
(if (file-exists? dashboard-ptree) (if (file-exists? dashboard-ptree)
(cached-require (->path dashboard-ptree) world:main-pollen-export) (cached-require (->path dashboard-ptree) world:main-pollen-export)
(directory->pagetree dashboard-dir)))))) (directory->pagetree dashboard-dir))))))
(body-wrapper (body-wrapper #:title (format "~a" dashboard-dir)
`(table `(table
,@(cons (make-parent-row) ,@(cons (make-parent-row)
(if (not (null? project-paths)) (if (not (null? project-paths))
(map make-path-row project-paths) (map make-path-row project-paths)
(list '(tr (td ((class "no-files")) "No files yet in this directory") (td) (td)))))))) (list '(tr (td ((class "no-files")) "No files yet in this directory") (td) (td))))))))
(define route-dashboard (route-wrapper dashboard)) (define route-dashboard (route-wrapper dashboard))
@ -212,8 +216,8 @@
(define base (world:current-project-root)) (define base (world:current-project-root))
(define file (url->path (request-uri req))) (define file (url->path (request-uri req)))
(if (eq? (system-path-convention-type) 'windows) (if (eq? (system-path-convention-type) 'windows)
(build-path base file) ; because url->path returns a relative path for 'windows (build-path base file) ; because url->path returns a relative path for 'windows
(reroot-path file base))) ; and a complete path for 'unix (reroot-path file base))) ; and a complete path for 'unix
;; default route ;; default route
(define (route-default req) (define (route-default req)
@ -228,7 +232,7 @@
(request? . -> . response?) (request? . -> . response?)
(define error-text (format "route-404: Can't find ~a" (->string (req->path req)))) (define error-text (format "route-404: Can't find ~a" (->string (req->path req))))
(message error-text) (message error-text)
(response/xexpr `(html ,error-text))) (response/xexpr+doctype `(html ,error-text)))

Write Preview
Loading…
Cancel
Save