working on server + server routes

11 years ago · 5c7777ab6a
parent 5ed2269bea
commit 5c7777ab6a
9 changed files with 116 additions and 46 deletions
--- a/pollen-file-tools.rkt
+++ b/pollen-file-tools.rkt
@ -90,10 +90,16 @@
 (check-equal? (filename-of (build-path (current-directory) "pollen-file-tools.rkt")) (->path "pollen-file-tools.rkt")))|#


+;; todo: tests for these predicates
+
 (define/contract (preproc-source? x)
  (any/c . -> . boolean?)
  (has-ext? (->path x) POLLEN_PREPROC_EXT))

+(module+ test
+  (check-true (preproc-source? "foo.pp"))
+  (check-false (preproc-source? "foo.bar")))
+
 (define/contract (has-preproc-source? x)
  (any/c . -> . boolean?)
  (file-exists? (make-preproc-source-path (->path x))))
@ -117,10 +123,31 @@
  (any/c . -> . boolean?)
  (has-ext? (->path x) POLLEN_MAP_EXT))

+(module+ test
+  (check-true (pmap-source? "foo.pmap"))
+  (check-false (pmap-source? "pmap.bar")))
+
+
 (define/contract (pollen-source? x)
  (any/c . -> . boolean?)
  (has-ext? (->path x) POLLEN_SOURCE_EXT))

+(module+ test
+  (check-true (pollen-source? "foo.p"))
+  (check-false (pollen-source? "foo.pp")))
+
+
+(define/contract (template-source? x)
+  (any/c . -> . boolean?)
+  (define-values (dir name ignore) (split-path x))
+  (equal? (get (->string name) 0) TEMPLATE_FILE_PREFIX))
+
+(module+ test
+  (check-true (template-source? "-foo.html"))
+  (check-false (template-source? "foo.html")))
+
+
+
 ;; this is for regenerate module.
 ;; when we want to be friendly with inputs for functions that require a path.
 ;; Strings & symbols often result from xexpr parsing
--- a/server-routes.rkt
+++ b/server-routes.rkt
@ -1,5 +1,5 @@
 #lang racket/base
-(require racket/list racket/contract racket/rerequire racket/file racket/format)
+(require racket/list racket/contract racket/rerequire racket/file racket/format xml)
 (require (only-in net/url url-query url->path))
 (require (only-in web-server/http/request-structs request-uri))
 (require "world.rkt" "regenerate.rkt" "readability.rkt" "predicates.rkt")
@ -12,61 +12,98 @@

 (provide (all-defined-out))

-
-(define/contract (file->xexpr path)
-  (complete-path? . -> . tagged-xexpr?)
-  (regenerate path)
-  (dynamic-rerequire path)
+;; extract main xexpr from a path
+(define/contract (file->xexpr path #:regen [regen #t])
+  ((complete-path?) (#:regen boolean?) . ->* . tagged-xexpr?)
+  (when regen (regenerate path)) ; refresh path 
+  (dynamic-rerequire path) ; stores module mod date; reloads if it's changed
  (dynamic-require path 'main))

+(module+ test
+  (check-equal? (file->xexpr (build-path (current-directory) "tests/server-routes/foo.p") #:regen #f) '(root "\n" "foo")))

-(define/contract (slurp path #:regenerate? [regenerate? #t])
-  (complete-path? . -> . string?) 
-  (when regenerate? (regenerate path))
+;; read contents of file to string
+;; just file->string with a regenerate option
+(define/contract (slurp path #:regen [regen #t])
+  ((complete-path?) (#:regen boolean?) . ->* . string?) 
+  (when regen (regenerate path))
  (file->string path))

-(define/contract (format-as-code tx)
-  (tagged-xexpr? . -> . tagged-xexpr?)
-  `(div ((style "white-space:pre-wrap;font-family:AlixFB,monospaced")) ,tx))
+(module+ test
+  (check-equal? (slurp (build-path (current-directory) "tests/server-routes/bar.html") #:regen #f) "<html><body><p>bar</p></body></html>"))
+
+
+;; add a wrapper to tagged-xexpr that displays it as monospaced text
+;; for "view source"ish functions
+;; 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"))))

+;; server routes
+;; these all produce an xexpr, which is handled upstream by (response/xexpr x)

+;; server route that returns html
+;; todo: what is this for?
 (define/contract (route-html path)
-  (complete-path? . -> . tagged-xexpr?)
+  (complete-path? . -> . xexpr?)
  (file->xexpr path))

+;; server route that returns raw html, formatted as code
+;; for viewing source without using "view source"
 (define/contract (route-raw-html path)
-  (complete-path? . -> . tagged-xexpr?)
+  (complete-path? . -> . xexpr?)
+  (format-as-code (slurp path #:regen #f)))
+
+;; todo: consolidate with function above, they're the same.
+;; server route that shows contents of file on disk
+(define/contract (route-source path)
+  (complete-path? . -> . xexpr?)
  (format-as-code (slurp path)))

+
+;; server route that returns xexpr (before conversion to html)
 (define/contract (route-xexpr path)
-  (complete-path? . -> . tagged-xexpr?)
+  (complete-path? . -> . xexpr?)
  (format-as-code (~v (file->xexpr path))))

-(define/contract (route-source path)
-  (complete-path? . -> . tagged-xexpr?)
-  (format-as-code (slurp path #:regenerate? #f)))


 (define/contract (route-index pollen-file-root)   
-  ((and/c path? complete-path?) . -> . tagged-xexpr?)
-  ; set up filter functions by mapping a function-maker for each file type
-  (define-values (pollen-file? preproc-file? pmap-file?)
-    (apply values (map (λ(ext)(λ(f)(has-ext? f ext))) (list POLLEN_SOURCE_EXT POLLEN_PREPROC_EXT POLLEN_MAP_EXT))))
-  (define (template-file? x)
-    (define-values (dir name ignore) (split-path x))
-    (equal? (get (->string name) 0) TEMPLATE_FILE_PREFIX))
-  ; get lists of files by mapping a filter function for each file type
+  (complete-path? . -> . xexpr?)
+  
+  ;; This function generates the Pollen dashboard.
+  ;; First, generate some lists of files.
+  
+  ;; get lists of files by mapping a filter function for each file type
  (define-values (pollen-files preproc-files pmap-files template-files)
-    (apply values (map (λ(test) (filter test (directory-list pollen-file-root))) (list pollen-file? preproc-file? pmap-file? template-file?))))
-  ; the actual post-p files may not have been generated yet
+    (let ([all-files-in-project-directory (directory-list pollen-file-root)])
+      (apply values 
+             (map (λ(test) (filter test all-files-in-project-directory)) 
+                  (list pollen-source? preproc-source? pmap-source? template-source?)))))
+  
+  ;; The actual post-preproc files may not have been generated yet
+  ;; so calculate their names (rather than rely on directory list)
  (define post-preproc-files (map (λ(path) (remove-ext path)) preproc-files))
-  ; make a combined list of p-files and post-p files
-  (define all-preproc-files (sort (append preproc-files post-preproc-files) #:key path->string string<?))
  
+  ;; Make a combined list of preproc files and post-preproc file, in alphabetical order
+  (define all-preproc-files (sort (append preproc-files post-preproc-files) 
+                                  #:key path->string string<?))
+  
+  ;; calculate names of post-pollen files
+  ;; todo: this isn't quite right. Assumes post-pollen file will have html extension.
+  ;; not necessarily true (it will assume the extension of its template.)
+  ;; But pulling out all the template extensions requires parsing all the files,
+  ;; which is slow and superfluous, since we're trying to be lazy about rendering.
  (define post-pollen-files (map (λ(path) (add-ext (remove-ext path) 'html)) pollen-files))
-  (define all-pollen-files (sort (append pollen-files post-pollen-files) #:key path->string string<?))
  
+  ;; Make a combined list of pollen files and post-pollen files, in alphabetical order
+  (define all-pollen-files (sort (append pollen-files post-pollen-files) #:key path->string string<?))
  
+  ;; Utility function for making file rows
  (define (make-file-row file routes)
    (define (make-link-cell type)
      (letrec ([source (add-ext (remove-ext file) POLLEN_SOURCE_EXT)]
@ -86,18 +123,18 @@
    `(tr ,(make-link-cell 'direct) ,@(map make-link-cell routes)))
  
  (if (andmap empty? (list pmap-files all-pollen-files all-preproc-files template-files))
-       '(body "No files yet. Get to work!")
+      '(body "No files yet. Get to work!")
      `(body 
-         (style ((type "text/css")) "td a { display: block; width: 100%; height: 100%; padding: 8px; }"
-                "td:hover {background: #eee}")
-         (table ((style "font-family:Concourse T3;font-size:115%"))
-                ; options for pmap files and template files
-                ,@(map (λ(file) (make-file-row file '(raw))) (append pmap-files template-files))
-                ; options for pollen files
-                ,@(map (λ(file) (make-file-row file '(raw source xexpr force))) post-pollen-files)
-                ; options for preproc files
-                ; branching in λ is needed so these files can be interleaved on the list
-                ,@(map (λ(file) (make-file-row file '(raw preproc-source))) post-preproc-files)))))
+        (style ((type "text/css")) "td a { display: block; width: 100%; height: 100%; padding: 8px; }"
+               "td:hover {background: #eee}")
+        (table ((style "font-family:Concourse T3;font-size:115%"))
+               ; options for pmap files and template files
+               ,@(map (λ(file) (make-file-row file '(raw))) (append pmap-files template-files))
+               ; options for pollen files
+               ,@(map (λ(file) (make-file-row file '(raw source xexpr force))) post-pollen-files)
+               ; options for preproc files
+               ; branching in λ is needed so these files can be interleaved on the list
+               ,@(map (λ(file) (make-file-row file '(raw preproc-source))) post-preproc-files)))))


 (define (get-query-value url key)
--- a/server.rkt
+++ b/server.rkt
@ -2,13 +2,14 @@
 #lang web-server
 (require web-server/servlet-env)
 (require web-server/dispatch web-server/dispatchers/dispatch)
+(require xml)
 (require "server-routes.rkt" "predicates.rkt")

 (displayln "Pollen server starting...")

 (define/contract (route-wrapper route-proc)
  ;; todo: make better contract for return value
-  ((complete-path? . -> . tagged-xexpr?) . -> . procedure?)
+  (procedure? . -> . procedure?)
  (λ(req string-arg) 
    (define filename string-arg)
    (response/xexpr (route-proc (build-path pollen-file-root filename)))))
@ -25,7 +26,7 @@
            ;; so extract the path manually
            (define req-uri (request-uri req))
            (define path (reroot-path (url->path req-uri) pollen-file-root))
-            (define force (get-query-value req-uri 'force))
+            (define force (equal? (get-query-value req-uri 'force) "true"))
            (route-preproc path #:force force)
            (next-dispatcher))]))

--- a/tests/favicon.ico
+++ b/tests/favicon.ico
@ -0,0 +1 @@
+
--- a/tests/server-routes/bar.html
+++ b/tests/server-routes/bar.html
@ -0,0 +1 @@
+<html><body><p>bar</p></body></html>
--- a/tests/server-routes/foo.html
+++ b/tests/server-routes/foo.html
@ -0,0 +1,2 @@
+FALLBACK! put-as-htmlroot
+                     foo
--- a/tests/server-routes/foo.p
+++ b/tests/server-routes/foo.p
@ -0,0 +1,2 @@
+#lang planet mb/pollen
+foo
--- a/tests/test-requirer.p
+++ b/tests/test-requirer.p
@ -1 +0,0 @@
-#lang racket/base
--- a/world.rkt
+++ b/world.rkt
@ -2,7 +2,7 @@

 (define POLLEN_PREPROC_EXT 'pp)
 (define POLLEN_SOURCE_EXT 'p)
-(define TEMPLATE_FILE_PREFIX #\-)
+(define TEMPLATE_FILE_PREFIX "-")
 (define POLLEN_EXPRESSION_DELIMITER #\◊)
 (define TEMPLATE_FIELD_DELIMITER POLLEN_EXPRESSION_DELIMITER)