start to improve dashboard handling of images

file-tools.rkt

@@ -7,6 +7,18 @@
 
 (module+ test (require rackunit))
 
+;; for files like svg that are not source in pollen terms,
+;; but have a textual representation separate from their display.
+(define/contract (sourceish? x)
+  (any/c . -> . boolean?)
+  (define sourceish-extensions
+    (list "svg"))
+  (with-handlers ([exn:fail? (λ(e) #f)])
+    (->boolean ((get-ext x) . in? . sourceish-extensions))))
+
+(module+ test
+  (check-true (sourceish? "foo.svg"))
+  (check-false (sourceish? "foo.gif")))
 
 ;; if something can be successfully coerced to a url,
 ;; it's urlish.

foobar/sample.svg

@@ -0,0 +1,28 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!-- Generator: Adobe Illustrator 15.1.0, SVG Export Plug-In . SVG Version: 6.00 Build 0)  -->
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd" [
+	<!ENTITY st0 "fill:#231F20;">
+]>
+<svg version="1.1" id="Layer_1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" x="0px" y="0px"
+	 width="265.39453px" height="171.71484px" viewBox="0 0 265.39453 171.71484"
+	 style="enable-background:new 0 0 265.39453 171.71484;" xml:space="preserve">
+<path style="&st0;" d="M191.73047,71.71484v-4.39844c0-5.51562-0.89453-9.82812-2.6875-12.92969
+	c-1.80469-3.10547-6.29297-7.32812-13.46484-12.67188l-25.92578,21.45703l2.99219,3.78516
+	c3.26562-3.17188,5.71875-4.75391,7.34766-4.75391c1.55859,0,2.9375,1.05469,4.16406,3.16797
+	c1.79688,3.07812,2.69922,9.04688,2.69922,17.89453V145.5l-9.14844,8.71484l21.64844,17.5l21.52344-17.5L191.73047,145.5V77.83203
+	l20.80859-16.69531l10.77734,11.38281v66.73828c0,8.72656,0.96094,15.03906,2.875,18.95312
+	c1.92188,3.92188,6.26953,8.42188,13.04688,13.50391l26.15625-21.46094l-2.98828-3.78125
+	c-4.24609,3.16797-6.94531,4.75391-8.08203,4.75391c-1.30469,0-2.49609-0.85547-3.55078-2.57031
+	c-1.71484-2.60547-2.57422-6.61328-2.57422-11.99609V78.52344c0-6.28516,0.81641-11.22266,2.45703-14.81641
+	c1.23047-2.69141,4.72266-6.65234,10.46875-11.875l-3.47266-3.29297l-11.89062,11.46875l-16.65234-18.29297L191.73047,71.71484z
+	 M91.78125,59.69922l9.14844,9.32812v68.05469c0,10.24609,0.9375,17.42578,2.8125,21.52734
+	c1.87891,4.10938,6.08203,8.47266,12.61328,13.10547L142.51562,150.5l-2.98828-3.78125
+	c-3.22656,2.68359-5.35938,4.30859-6.39062,4.87891c-0.73047,0.40234-1.53906,0.60156-2.42578,0.60156
+	c-1.24609,0-2.45703-1.05469-3.62891-3.16016c-1.17969-2.12109-1.75781-6.67188-1.75781-13.66797V69.02734l9.62891-9.32812
+	L113.3125,41.71484L91.78125,59.69922z M116.29688,26.34375h4.875L137.99609,0h-15.48438L116.29688,26.34375z M63.58984,89.44922
+	l-32.125,22.51172v-55.375l1.71094-0.84766L63.58984,89.44922z M25.97656,54.64062
+	c-5.04297,2.27734-11.37891,4.79688-19.02344,7.5625v69.75391c0,7.97266-0.46875,13.15625-1.40625,15.55859
+	C4.61719,149.91016,2.76172,151.91797,0,153.54688v3.05078c9.61328,2.03516,17.01562,3.98438,22.22656,5.85156
+	c5.21484,1.875,11.85156,4.96094,19.91016,9.26562l39.45312-27.5625l-2.68359-3.65625l-19.14453,13.05078l-28.29688-11.22266
+	v-22.19141l54.64062-38.29688L51.71094,41.71484C38.21094,48.625,29.63672,52.92969,25.97656,54.64062"/>
+</svg>

server-routes.rkt

@@ -79,14 +79,49 @@
   (xexpr? . -> . tagged-xexpr?)
   (body-wrapper `(tt ,x)))
 
+(define/contract (bytecount->string bytecount)
+  (integer? . -> . string?)
+  (define (format-with-threshold threshold suffix)
+    ;; upconvert by factor of 100 to get two digits after decimal
+    (format "~a ~a" (exact->inexact (/ (round ((* bytecount 100) . / . threshold)) 100)) suffix))
+  
+  (define threshold-gigabyte 1000000000)
+  (define threshold-megabyte (threshold-gigabyte . / . 1000))
+  (define threshold-kilobyte (threshold-megabyte . / . 1000))
   
-(define/contract (make-binary-info-page path)
-  (complete-path? . -> . xexpr?)
   (cond
-    [((get-ext path) . in? . '("gif" "jpg" "jpeg" "png")) 
+    [(bytecount . > . threshold-gigabyte) (format-with-threshold threshold-gigabyte "GB")]
+    [(bytecount . > . threshold-megabyte) (format-with-threshold threshold-megabyte "MB")]
+    [(bytecount . > . threshold-kilobyte) (format-with-threshold threshold-kilobyte "KB")]
+    [else (format "~a bytes" bytecount)]))
+
+
+(define-syntax-rule (when/splice test body) (if test (list body) '()))
+
+
+(require 2htdp/image)
+(define (handle-image-path p)
+  (pathish? . -> . xexpr?)
+  (define path (->complete-path p))
+  (define img (bitmap/file path))
+  (define relative-path (->string (find-relative-path PROJECT_ROOT path)))
+  (define img-url (format "/~a" relative-path))
   `(div    
-       (img ((src ,(path->string path))))
+    (p "filename =" ,(->string relative-path))
-       (p "path =" ,(path->string 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))))
+    (a ((href ,img-url)) (img ((style "width:100%")(src ,img-url))))))
+
+
+
+(define/contract (make-binary-info-page p)
+  (pathish? . -> . xexpr?)
+  (define path (->complete-path p))
+  (cond
+    [((get-ext path) . in? . '("gif" "jpg" "jpeg" "png" "svg")) 
+     (handle-image-path path)]
     [else '(p "We got some other kind of binary file.")]))
 
 ;; server routes
@@ -102,7 +137,7 @@
 (define/contract (out path)
   (complete-path? . -> . xexpr?)
   (cond
-    [(has-binary-ext? path) (make-binary-info-page path)]
+    [(or (has-binary-ext? path) (sourceish? path)) (make-binary-info-page path)]
     [else (format-as-code (slurp path #:render #t))]))
 (define route-out (route-wrapper out))
 
@@ -146,6 +181,7 @@
                          (cond ; in cell
                            [(has-ext? filename POLLEN_TREE_EXT) (cons (format "in/~a" filename) "ptree")]
                            [source  (cons (format "in/~a" source) "in")]
+                           [(sourceish? filename)  (cons (format "in/~a" filename) "in")]
                            [else empty-cell])
                          
                          (cond ; out cell 
@@ -213,5 +249,6 @@
 (module+ main
   (parameterize ([current-directory (build-path (current-directory) "foobar")])
     (reset-project-root)
-    (message PROJECT_ROOT)
+    ;    (message PROJECT_ROOT)
-    (dashboard (build-path "poldash.html"))))
+    ;    (make-binary-info-page (build-path "foo.gif"))
+    ))