|
|
|
|
@ -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 #"<!DOCTYPE html>" 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)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
