diff --git a/pollen/private/project-server-routes.rkt b/pollen/private/project-server-routes.rkt index 7b09765..ea9b4d2 100644 --- a/pollen/private/project-server-routes.rkt +++ b/pollen/private/project-server-routes.rkt @@ -61,11 +61,11 @@ (define client (request-client-ip req)) (define localhost-client "::1") (define url-string (url->string (request-uri req))) - (when (not (ends-with? url-string "favicon.ico")) - (message "request:" (if (regexp-match #rx"/$" url-string) - (string-append url-string " directory default page") - (string-replace url-string (setup:main-pagetree) " dashboard")) - (if (not (equal? client localhost-client)) (format "from ~a" client) "")))) + (unless (ends-with? url-string "favicon.ico") + (message (if (regexp-match #rx"/$" url-string) + (string-append url-string " directory default page") + (string-replace url-string (setup:main-pagetree) " dashboard")) + (if (not (equal? client localhost-client)) (format "from ~a" client) ""))) ;; pass string args to route, then ;; package route into right format for web server @@ -164,9 +164,9 @@ (define (make-link-cell href+text) (match-define (cons href text) href+text) (filter-not void? `(cell ,(when text - (if href - `(a ((href ,href)) ,text) - text))))) + (if href + `(a ((href ,href)) ,text) + text))))) (define (make-parent-row) (define title (string-append "Project root" (if (equal? (current-project-root) dashboard-dir) (format " = ~a" dashboard-dir) ""))) @@ -180,51 +180,51 @@ (define (make-path-row filename source indent-level) `(row ,@(map make-link-cell - (append (list - (let ([main-cell (cond ; main cell - [(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard - (cons (format "~a/~a" filename (setup:main-pagetree)) (format "~a/" filename))] - [(and source (equal? (get-ext source) "scrbl")) ; scribble source - (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))] - [source ; ordinary source. use remove-ext because source may have escaped extension in it - (define source-first-ext (get-ext source)) - (define source-minus-ext (unescape-ext (remove-ext source))) - (define source-second-ext (get-ext source-minus-ext)) - (cond ; multi source. expand to multiple output files. - [(and source-second-ext (equal? source-second-ext (->string (setup:poly-source-ext (->complete-path source))))) - (define source-base (remove-ext source-minus-ext)) - (define output-names (map (λ (ext) (->string (add-ext source-base ext))) (setup:poly-targets (->complete-path source)))) - (cons #f `(div ,@(map (λ (on) `(a ((href ,on)) ,on (span ((class "file-ext")) "." ,source-first-ext ,(format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))) output-names)))] - [else - (define extra-row-string - (if (equal? source-minus-ext (remove-ext source)) ; escaped and unescaped versions are equal - "" ; no extra string needed - (format " (from ~a)" (->string (find-relative-path dashboard-dir source))))) + (append (list + (let ([main-cell (cond ; main cell + [(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard + (cons (format "~a/~a" filename (setup:main-pagetree)) (format "~a/" filename))] + [(and source (equal? (get-ext source) "scrbl")) ; scribble source + (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))] + [source ; ordinary source. use remove-ext because source may have escaped extension in it + (define source-first-ext (get-ext source)) + (define source-minus-ext (unescape-ext (remove-ext source))) + (define source-second-ext (get-ext source-minus-ext)) + (cond ; multi source. expand to multiple output files. + [(and source-second-ext (equal? source-second-ext (->string (setup:poly-source-ext (->complete-path source))))) + (define source-base (remove-ext source-minus-ext)) + (define output-names (map (λ (ext) (->string (add-ext source-base ext))) (setup:poly-targets (->complete-path source)))) + (cons #f `(div ,@(map (λ (on) `(a ((href ,on)) ,on (span ((class "file-ext")) "." ,source-first-ext ,(format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))) output-names)))] + [else + (define extra-row-string + (if (equal? source-minus-ext (remove-ext source)) ; escaped and unescaped versions are equal + "" ; no extra string needed + (format " (from ~a)" (->string (find-relative-path dashboard-dir source))))) - (cons #f `(a ((href ,filename)) ,(->string source-minus-ext) (span ((class "file-ext")) "." ,source-first-ext ,extra-row-string)))])] - [else ; other non-source file - (cons filename filename)])]) + (cons #f `(a ((href ,filename)) ,(->string source-minus-ext) (span ((class "file-ext")) "." ,source-first-ext ,extra-row-string)))])] + [else ; other non-source file + (cons filename filename)])]) - (cons (car main-cell) - (let* ([cell-content (cdr main-cell)] - [indent-padding (+ 1 indent-level)] - [padding-attr `(class ,(format "indent_~a" indent-padding))]) - (cond - [(string? cell-content) `(span (,padding-attr) ,cell-content)] - [(txexpr? cell-content) - ;; indent link text by depth in pagetree - `(,(get-tag cell-content) ,(cons padding-attr (get-attrs cell-content)) ,@(get-elements cell-content))] - [else (error 'make-path-row (format "mysterious cell data: ~v" cell-content))])))) + (cons (car main-cell) + (let* ([cell-content (cdr main-cell)] + [indent-padding (+ 1 indent-level)] + [padding-attr `(class ,(format "indent_~a" indent-padding))]) + (cond + [(string? cell-content) `(span (,padding-attr) ,cell-content)] + [(txexpr? cell-content) + ;; indent link text by depth in pagetree + `(,(get-tag cell-content) ,(cons padding-attr (get-attrs cell-content)) ,@(get-elements cell-content))] + [else (error 'make-path-row (format "mysterious cell data: ~v" cell-content))])))) - (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 ; '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")])))))) + (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 (setup:paths-excluded-from-dashboard))) @@ -241,32 +241,32 @@ depth))) (apply body-wrapper #:title (format "~a" dashboard-dir) - (cons (make-parent-row) - (cond - [(not (null? project-paths)) - (define path-source-pairs - (map - (λ (p) (define source - (let ([possible-source (get-source (build-path dashboard-dir p))]) - (and possible-source (->string (find-relative-path dashboard-dir possible-source))))) - (cons p source)) - project-paths)) + (cons (make-parent-row) + (cond + [(not (null? project-paths)) + (define path-source-pairs + (map + (λ (p) (define source + (let ([possible-source (get-source (build-path dashboard-dir p))]) + (and possible-source (->string (find-relative-path dashboard-dir possible-source))))) + (cons p source)) + project-paths)) - (define-values (reversed-unique-path-source-pairs seen-paths) ; delete pairs with duplicate sources - (for/fold ([psps empty][seen-source-paths empty]) - ([psp (in-list path-source-pairs)]) - (define source-path (cdr psp)) - (if (and source-path (member source-path seen-source-paths)) - (values psps seen-source-paths) ; skip the pair - (values (cons psp psps) (cons source-path seen-source-paths))))) + (define-values (reversed-unique-path-source-pairs seen-paths) ; delete pairs with duplicate sources + (for/fold ([psps empty][seen-source-paths empty]) + ([psp (in-list path-source-pairs)]) + (define source-path (cdr psp)) + (if (and source-path (member source-path seen-source-paths)) + (values psps seen-source-paths) ; skip the pair + (values (cons psp psps) (cons source-path seen-source-paths))))) - (define unique-path-source-pairs (reverse reversed-unique-path-source-pairs)) - (define filenames (map (compose1 ->string car) unique-path-source-pairs)) - (define sources (map cdr unique-path-source-pairs)) - (define indent-levels (map directory-pagetree-depth filenames)) - (parameterize ([current-directory dashboard-dir]) - (map make-path-row filenames sources indent-levels))] - [else (list '(row (cell ((class "no-files")) "No files yet in this directory") (td) (td)))])))) + (define unique-path-source-pairs (reverse reversed-unique-path-source-pairs)) + (define filenames (map (compose1 ->string car) unique-path-source-pairs)) + (define sources (map cdr unique-path-source-pairs)) + (define indent-levels (map directory-pagetree-depth filenames)) + (parameterize ([current-directory dashboard-dir]) + (map make-path-row filenames sources indent-levels))] + [else (list '(row (cell ((class "no-files")) "No files yet in this directory") (td) (td)))])))) (define route-dashboard (route-wrapper dashboard)) @@ -307,7 +307,7 @@ (define/contract (route-404 req) (request? . -> . response?) (define missing-path-string (path->string (simplify-path (req->path req)))) - (message (format "route-404: Can't find ~a" missing-path-string)) + (message (format "can't find ~a" missing-path-string)) (response/xexpr+doctype `(html (head (title "404 error") (link ((href "/error.css") (rel "stylesheet")))) diff --git a/pollen/render.rkt b/pollen/render.rkt index b6adecb..db91ad0 100644 --- a/pollen/render.rkt +++ b/pollen/render.rkt @@ -107,7 +107,7 @@ #:dest-path 'output #:notify-cache-use (λ (str) - (message (format "rendering: /~a (from cache)" + (message (format "loading from cache /~a" (find-relative-path (current-project-root) output-path))))))))) ; will either be string or bytes (display-to-file render-result output-path #:exists 'replace @@ -145,16 +145,19 @@ (raise-argument-error 'render (format "valid rendering function for ~a" source-path) render-proc)) (define template-path (or maybe-template-path (get-template-for source-path output-path))) - (message (format "rendering: /~a as /~a" - (find-relative-path (current-project-root) source-path) - (find-relative-path (current-project-root) output-path))) + ;; output-path and template-path may not have an extension, so check them in order with fallback - (define render-result (parameterize ([current-poly-target (->symbol (or (get-ext output-path) - (and template-path (get-ext template-path)) - (current-poly-target)))]) - (apply render-proc (list source-path template-path output-path)))) + (match-define-values ((cons render-result _) _ real _) + (parameterize ([current-poly-target (->symbol (or (get-ext output-path) + (and template-path (get-ext template-path)) + (current-poly-target)))]) + (time-apply render-proc (list source-path template-path output-path)))) ;; wait till last possible moment to store mod dates, because render-proc may also trigger its own subrenders - ;; e.g., of a template. + ;; e.g., of a template. + (message (format "rendering /~a as /~a (~a ms)" + (find-relative-path (current-project-root) source-path) + (find-relative-path (current-project-root) output-path) + real)) (update-mod-date-hash! source-path template-path) render-result) @@ -169,29 +172,29 @@ (local-require scribble/core scribble/manual (prefix-in scribble- scribble/render)) (define source-dir (dirname source-path)) ;; make fresh namespace for scribble rendering (avoids dep/zo caching) - (time (parameterize ([current-namespace (make-base-namespace)] - [current-directory (->complete-path source-dir)]) - (define ns (namespace-anchor->namespace render-module-ns)) - (namespace-attach-module ns 'scribble/core (current-namespace)) - (namespace-attach-module ns 'scribble/manual (current-namespace)) - ;; scribble/lp files have their doc export in a 'doc submodule, so check both locations - (match (cond - [(dynamic-require source-path 'doc (λ () #false))] - [(dynamic-require `(submod ,source-path doc) 'doc (λ () #false))] - [else #false]) - ;; BTW this next action has side effects: scribble will copy in its core files if they don't exist. - [(? part? doc) (scribble-render (list doc) (list source-path))] - [_ (void)]))) + (parameterize ([current-namespace (make-base-namespace)] + [current-directory (->complete-path source-dir)]) + (define ns (namespace-anchor->namespace render-module-ns)) + (namespace-attach-module ns 'scribble/core (current-namespace)) + (namespace-attach-module ns 'scribble/manual (current-namespace)) + ;; scribble/lp files have their doc export in a 'doc submodule, so check both locations + (match (cond + [(dynamic-require source-path 'doc (λ () #false))] + [(dynamic-require `(submod ,source-path doc) 'doc (λ () #false))] + [else #false]) + ;; BTW this next action has side effects: scribble will copy in its core files if they don't exist. + [(? part? doc) (scribble-render (list doc) (list source-path))] + [_ (void)])) (begin0 ; because render promises the data, not the side effect (file->string (->output-path source-path)) (delete-file (->output-path source-path)))) (define (render-preproc-source source-path . _) - (time (parameterize ([current-directory (->complete-path (dirname source-path))]) - (render-datum-through-eval (syntax->datum - (with-syntax ([SOURCE-PATH source-path]) - #'(begin (require pollen/cache) - (cached-doc SOURCE-PATH)))))))) + (parameterize ([current-directory (->complete-path (dirname source-path))]) + (render-datum-through-eval (syntax->datum + (with-syntax ([SOURCE-PATH source-path]) + #'(begin (require pollen/cache) + (cached-doc SOURCE-PATH))))))) (define (render-markup-or-markdown-source source-path [maybe-template-path #f] [maybe-output-path #f]) (define output-path (or maybe-output-path (->output-path source-path))) @@ -229,8 +232,8 @@ DOC-ID (include-template #:command-char COMMAND-CHAR (file TEMPLATE-PATH)))))))) ;; set current-directory because include-template wants to work relative to source location - (time (parameterize ([current-directory (->complete-path (dirname source-path))]) - (render-datum-through-eval datum-to-eval)))) + (parameterize ([current-directory (->complete-path (dirname source-path))]) + (render-datum-through-eval datum-to-eval))) (define (templated-source? path) (or (markup-source? path) (markdown-source? path)))