You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
pollen/server-routes.rkt

247 lines
9.9 KiB
Racket

#lang racket/base
(require racket/list racket/contract racket/rerequire racket/file racket/format xml racket/match racket/set racket/string racket/promise racket/path)
11 years ago
(require web-server/http/xexpr web-server/dispatchers/dispatch)
(require net/url)
(require web-server/http/request-structs)
(require web-server/http/response-structs)
(require 2htdp/image)
(require "world.rkt" "render.rkt" sugar txexpr "predicates.rkt" "debug.rkt" "ptree.rkt")
(module+ test (require rackunit))
;;; Routes for the server module
;;; separated out for ease of testing
;;; because it's tedious to start the server just to check a route.
11 years ago
(provide route-dashboard route-xexpr route-default route-404 route-in route-out)
11 years ago
11 years ago
(define (body-wrapper content-xexpr)
`(html
(head
(meta ([charset "UTF-8"]))
(link ([rel "stylesheet"]
[type "text/css"]
[href ,(format "/~a" DASHBOARD_CSS)])))
11 years ago
(body
,content-xexpr (div ((id "pollen-logo"))))))
;; 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?)
11 years ago
(define client (request-client-ip req))
(define localhost-client "::1")
11 years ago
(define url-string (url->string (request-uri req)))
(message "Request:" (string-replace url-string DASHBOARD_NAME " dashboard")
(if (not (equal? client localhost-client)) (format "from ~a" client) "")))
11 years ago
;; 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?)
11 years ago
(define/contract (route-wrapper route-proc)
(procedure? . -> . procedure?)
(λ(req . string-args)
(logger req)
(define path (apply build-path (CURRENT_PROJECT_ROOT) (flatten string-args)))
11 years ago
(response/xexpr (route-proc path))))
;; extract main xexpr from a path
11 years ago
(define/contract (file->xexpr path #:render [wants-render #t])
((complete-path?) (#:render boolean?) . ->* . txexpr?)
11 years ago
(when wants-render (render path))
(dynamic-rerequire path) ; stores module mod date; reloads if it's changed
11 years ago
(dynamic-require path 'main))
11 years ago
;; todo: rewrite this test, obsolete since filename convention changed
;;(module+ test
;; (check-equal? (file->xexpr (build-path (current-directory) "tests/server-routes/foo.p") #:render #f) '(root "\n" "foo")))
;; read contents of file to string
11 years ago
;; just file->string with a render option
(define/contract (slurp path #:render [wants-render #t])
((complete-path?) (#:render boolean?) . ->* . string?)
(when wants-render (render path))
(file->string path))
(module+ test
11 years ago
(check-equal? (slurp (build-path (current-directory) "tests/server-routes/bar.html") #:render #f) "<html><body><p>bar</p></body></html>"))
;; add a wrapper to txexpr 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? . -> . txexpr?)
11 years ago
(body-wrapper `(tt ,x)))
(define (handle-image-path p)
(pathish? . -> . xexpr?)
(define path (->complete-path p))
(define img (bitmap/file path))
(define relative-path (->string (find-relative-path (CURRENT_PROJECT_ROOT) path)))
(define img-url (format "/~a" relative-path))
11 years ago
`(div
(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))))
11 years ago
(a ((href ,img-url)) (img ((style "width:100%;border:1px solid #eee")(src ,img-url))))))
(require file/unzip)
(define (handle-zip-path p)
(pathish? . -> . xexpr?)
(define path (->path p))
(define relative-path (->string (find-relative-path (CURRENT_PROJECT_ROOT) path)))
(define ziplist (zip-directory-entries (read-zip-directory path)))
`(div
(p "filename =" ,(->string relative-path))
(p "size = " ,(bytecount->string (file-size path)))
(ul ,@(map (λ(i) `(li ,(~a i))) ziplist))))
(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)]
[((get-ext path) . in? . '("zip")) (handle-zip-path path)]
[else '(p "We got some other kind of binary file.")]))
;; server routes
;; these all produce an xexpr, which is handled upstream by response/xexpr
11 years ago
;; server routes that show result, formatted as code
;; route-in just gets file from disk; route-out renders it first
(define/contract (in path)
(complete-path? . -> . xexpr?)
11 years ago
(format-as-code (slurp path #:render #f)))
11 years ago
(define route-in (route-wrapper in))
11 years ago
(define/contract (out path)
(complete-path? . -> . xexpr?)
(cond
[(or (has-binary-ext? path) (sourceish? path)) (make-binary-info-page path)]
[else (format-as-code (slurp path #:render #t))]))
11 years ago
(define route-out (route-wrapper out))
;; dashboard route
11 years ago
(define (dashboard dashfile)
(define dir (get-enclosing-dir dashfile))
(define (in-project-root?)
(directories-equal? dir (CURRENT_PROJECT_ROOT)))
(define parent-dir (and (not (in-project-root?)) (get-enclosing-dir dir)))
11 years ago
(define empty-cell (cons #f #f))
11 years ago
(define (make-link-cell href+text)
(match-define (cons href text) href+text)
11 years ago
(filter-not void? `(td ,(when text
(if href
`(a ((href ,href)) ,text)
text)))))
(define (make-parent-row)
11 years ago
(if parent-dir
(let* ([url-to-parent-dashboard (format "/~a" (find-relative-path (CURRENT_PROJECT_ROOT) (build-path parent-dir DASHBOARD_NAME)))]
11 years ago
[url-to-parent (string-replace url-to-parent-dashboard DASHBOARD_NAME "")])
`(tr (th ((colspan "3")) (a ((href ,url-to-parent-dashboard)) ,(format "up to ~a" url-to-parent)))))
`(tr (th ((colspan "3")(class "root")) "Pollen root"))))
11 years ago
(define (make-path-row fn)
(define filename (->string fn))
(define (file-in-dir? fn) (file-exists? (build-path dir fn)))
(define possible-sources
(if (directory-exists? fn)
empty ;; folders don't have source files
(filter file-in-dir? (list (->preproc-source-path filename) (->decoder-source-path filename) (->null-source-path filename)))))
11 years ago
(define source (and (not (empty? possible-sources)) (->string (car possible-sources))))
11 years ago
`(tr ,@(map make-link-cell
(append (list
11 years ago
(cond ; main cell
11 years ago
[(directory-exists? (build-path dir filename)) ; links subdir to its dashboard
(cons (format "~a/~a" filename DASHBOARD_NAME) (format "~a/" filename))]
[source (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) "." ,(get-ext source))))]
[else (cons filename filename)])
11 years ago
(cond ; in cell
[source (cons (format "in/~a" source) "in")]
[(or (ptree-source? filename) (sourceish? filename)) (cons (format "in/~a" filename) "in")]
11 years ago
[else empty-cell])
11 years ago
(cond ; out cell
11 years ago
[(directory-exists? (build-path dir filename)) (cons #f #f)]
[(ptree-source? filename) empty-cell]
11 years ago
[else (cons (format "out/~a" filename) "out")]))))))
11 years ago
(define (ineligible-path? x) (or (not (visible? x)) (member x RESERVED_PATHS)))
(define (unique-sorted-output-paths xs)
11 years ago
(define output-paths (map ->output-path xs))
(define (unique-members xs) (set->list (list->set xs)))
(define all-paths (unique-members output-paths))
(define path-is-directory? (λ(f) (directory-exists? (build-path dir f))))
(define subdirectories (filter path-is-directory? all-paths))
(define files (filter-not path-is-directory? all-paths))
(define ptree-sources (filter ptree-source? files))
(define other-files (filter-not ptree-source? files))
11 years ago
(define (sort-names xs) (sort xs #:key ->string string<?))
;; put subdirs in list ahead of files (so they appear at the top)
(append (sort-names subdirectories) (sort-names ptree-sources) (sort-names other-files)))
(define project-paths (filter-not ineligible-path? (if (file-exists? dashfile)
(map ->path (ptree->list (file->ptree dashfile)))
(unique-sorted-output-paths (directory-list dir)))))
11 years ago
(body-wrapper
`(table
,@(cons (make-parent-row)
(map make-path-row 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))))
(define/contract (req->path req)
(request? . -> . path?)
(reroot-path (url->path (request-uri req)) (CURRENT_PROJECT_ROOT)))
;; default route
(define (route-default req)
11 years ago
(logger req)
(define force (equal? (get-query-value (request-uri req) 'force) "true"))
(render (req->path req) #:force force)
11 years ago
(next-dispatcher))
;; 404 route
(define/contract (route-404 req)
(request? . -> . response?)
(define error-text (format "route-404: Can't find ~a" (->string (req->path req))))
(message error-text)
(response/xexpr `(html ,error-text)))
11 years ago
11 years ago
;; server route that returns xexpr (before conversion to html)
(define/contract (xexpr path)
(complete-path? . -> . xexpr?)
(format-as-code (~v (file->xexpr path))))
11 years ago
(define route-xexpr (route-wrapper xexpr))