make parent row navigation for dashboard

file-tools.rkt

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

pollen-server-extras/poldash.css

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

server-routes.rkt

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

world.rkt

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