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