#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) (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 "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 route-dashboard route-raw route-xexpr route-default route-404) (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) (define path (apply build-path PROJECT_ROOT (flatten string-args))) (response/xexpr (route-proc path)))) ;; extract main xexpr from a path (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 (dynamic-require path 'main)) ;; 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 ;; 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 (check-equal? (slurp (build-path (current-directory) "tests/server-routes/bar.html") #:render #f) "

bar

")) ;; 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?) (html-wrapper `(tt ,x))) ;; server routes ;; these all produce an xexpr, which is handled upstream by response/xexpr ;; server route that returns raw html, formatted as code ;; for viewing source without using "view source" (define/contract (raw path) (complete-path? . -> . xexpr?) (format-as-code (slurp path #:render #f))) (define route-raw (route-wrapper raw)) ;; dashboard route (define (dashboard dashfile) (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) (filter-not void? `(td ,(when text (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 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 (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 (cond ;; main cell [(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)]) (cond ; source cell (if needed) [(has-ext? filename POLLEN_TREE_EXT) (cons (format "raw/~a" filename) "ptree")] [source (cons (format "raw/~a" source) "in")] [else empty-cell]) (cond ; raw cell (if needed) [(directory-exists? (build-path dir filename)) (cons #f #f)] [(has-binary-ext? filename) (cons #f "(binary)")] [(has-ext? filename POLLEN_TREE_EXT) empty-cell] [else (cons (format "raw/~a" filename) "out")])) #|(if source (list (if (has-ext? source POLLEN_DECODER_EXT) ; xexpr cell for pollen decoder files (cons (format "xexpr/~a" source) "xexpr") empty-cell)) (make-list 1 empty-cell))|#)))) (define (ineligible-path? x) (or (not (visible? x)) (member x RESERVED_PATHS))) (define project-paths (filter-not ineligible-path? (directory-list dir))) (define (unique-sorted-output-paths xs) (define all-paths (set->list (list->set (map ->output-path xs)))) (define subdirectories (filter directory-exists? all-paths)) (define files (filter-not directory-exists? all-paths)) (report (append (sort subdirectories #:key ->string stringstring stringpath req) (request? . -> . path?) (reroot-path (url->path (request-uri req)) PROJECT_ROOT)) ;; default route (define (route-default req) (logger req) (define force (equal? (get-query-value (request-uri req) 'force) "true")) (with-handlers ([exn:fail? (λ(e) (message "Render is skipping" (url->string (request-uri req)) "because of error\n" (exn-message e)))]) (render (req->path req) #:force force)) (next-dispatcher)) ;; error route (define/contract (route-404 req) (request? . -> . response?) (define error-text (format "Can't find ~a" (->string (req->path req)))) (message error-text) ;`(html ,(slurp (build-path SERVER_EXTRAS_DIR "404.html"))) (response/xexpr `(html ,error-text))) ;; 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"))))