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

124 lines
5.2 KiB
Racket

#lang racket/base
11 years ago
(require racket/list racket/contract racket/rerequire racket/file racket/format xml racket/match racket/set)
(require (only-in net/url url-query url->path url->string))
(require (only-in web-server/http/request-structs request-uri request-client-ip))
11 years ago
(require "world.rkt" "render.rkt" "readability.rkt" "predicates.rkt" "debug.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.
(provide (all-defined-out))
;; extract main xexpr from a path
11 years ago
(define/contract (file->xexpr path #:render [wants-render #t])
((complete-path?) (#:render boolean?) . ->* . tagged-xexpr?)
(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 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
;; 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"
11 years ago
(define/contract (route-raw path)
(complete-path? . -> . xexpr?)
11 years ago
(format-as-code (slurp path #:render #f)))
;; server route that returns xexpr (before conversion to html)
(define/contract (route-xexpr path)
(complete-path? . -> . xexpr?)
(format-as-code (~v (file->xexpr path))))
11 years ago
(define empty-cell (cons #f #f))
(define (route-dashboard dir)
11 years ago
(define (make-link-cell href+text)
(match-define (cons href text) href+text)
(filter-not void? `(td ,(when (and href text)
`(a ((href ,href)) ,text)))))
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 (filter file-in-dir? (list (->preproc-source-path filename) (->pollen-source-path filename))))
(define source (and (not (empty? possible-sources)) (->string (car possible-sources))))
11 years ago
`(tr ,@(map make-link-cell
(append (list
11 years ago
;; folder traversal cell
(if (directory-exists? (build-path dir filename)) ; link subdirs to dashboard
(cons (format "~a/~a" filename DASHBOARD_NAME) "dash")
empty-cell)
(cons filename filename) ; main cell
(if source
(cons source (format "~a input" (get-ext source)))
empty-cell)
(cond
[(directory-exists? (build-path dir filename)) "(folder)"]
;; [(directory-exists? (build-path dir filename)) "(binary)"]
[else (cons (format "raw/~a" filename) "output")]))
11 years ago
(if source
(list
(cons (format "xexpr/~a" source) "xexpr")
11 years ago
(cons (format "~a?force=true" filename) filename))
(make-list 2 empty-cell))))))
11 years ago
(define (unique-sorted-output-paths xs)
(sort (set->list (list->set (map ->output-path xs))) #:key ->string string<?))
11 years ago
(define (ineligible-path? x) (or (not (visible? x)) (member x RESERVED_PATHS)))
11 years ago
(define project-paths (filter-not ineligible-path? (directory-list dir)))
11 years ago
`(table ,@(map make-path-row (unique-sorted-output-paths project-paths))))
(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
; default route
(define (route-default req)
(define request-url (request-uri req))
11 years ago
(define path (reroot-path (url->path request-url) PROJECT_ROOT))
(define force (equal? (get-query-value request-url 'force) "true"))
11 years ago
(with-handlers ([exn:fail? (λ(e) (message "Render is skipping" (url->string request-url) "because of error\n" (exn-message e)))])
(render path #:force force)))