#lang racket (require racket/date (only-in racket/list first second third rest) (only-in racket/string string-prefix? string-replace) net/url xml web-server/web-server web-server/servlet-dispatch web-server/dispatchers/dispatch web-server/dispatch (prefix-in files: web-server/dispatchers/dispatch-files) (prefix-in filter: web-server/dispatchers/dispatch-filter) (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) racket/runtime-path web-server/dispatchers/filesystem-map web-server/http csv-reading) ;; namespace needed for evaluating read files (define-namespace-anchor anc) (define ns (namespace-anchor->namespace anc)) ;; it's all html! (define (html-response content) (response/full 200 #"OK" (current-seconds) TEXT/HTML-MIME-TYPE '() (list content))) ;; bound path builders ;; extension is always #".scm" because source files are not racket, ;; but must be read and evaluated in this namespace (define (make-path-no-param root-folder extension) (lambda (t) (path-add-extension (if (and (non-empty-string? t) (not (eq? t "root"))) (build-path root-folder t "index") (build-path root-folder "index")) extension))) (define (make-path-id-param root-folder extension) (lambda (t id) (path-add-extension (build-path root-folder (if (eq? t "root") (if (eq? id "") ;; if "root/" something weird has happened "index" ;; allows for loading "/about" and other root resources (~a id)) (if ;; if url has trailing backslash, id will be an empty string ;; and should return index for that type (or (not (string? id)) (non-empty-string? id)) (build-path t (~a id)) (build-path t "index")))) extension))) (define (make-source-path-no-param t) ((make-path-no-param "source" #".scm") t)) (define (make-source-path-id-param t id) ((make-path-id-param "source" #".scm") t id)) (define (make-static-path-no-param api-type t) (let ([root-folder (cond [(eq? api-type 'httpx) "static/fragment"] [(eq? api-type 'page) "static/page"] [else (error "api-type ~a not recognized" api-type)])]) ((make-path-no-param root-folder #".html") t))) (define (make-static-path-id-param api-type t id) (let ([root-folder (cond [(eq? api-type 'httpx) "static/fragment"] [(eq? api-type 'page) "static/page"] [else (error "api-type ~a not recognized" api-type)])]) ((make-path-id-param root-folder #".html") t id))) (define (static-file-res static-path) (string->bytes/utf-8 (file->string static-path))) ;; wrapper for resource-processor (define (wrapper-for-resource-processor static-path res-processor) (if (not (file-exists? static-path)) (html-response (static-file-res static-path)) (res-processor))) ;; write static-file ;; return data that was written (define (write-static-file static-path) (lambda (data) (let ([out-port (open-output-file static-path #:exists 'error)]) (if (port-try-file-lock? out-port 'exclusive) (begin (display data out-port) (port-file-unlock out-port) (close-output-port out-port) data) (error "couldn't obtain file lock on ~a" out-port))))) (define (404-handler api-type) (cond [(eq? api-type 'httpx) (404-hx)] [(eq? api-type 'page) (404-page)] [else (error "api-type ~a not recognized" api-type)])) ;; takes a resource-type (corresponds to the REST resource and the system path or ;; an index resource in the source path) ;; and a resource-processor (-> file-handle . http-response) ;; and returns a valid html-response irrespective of hx/ type fragment of html or full page (define respond-resource-with-processor (lambda (api-type res-type resource-processor) ;; this lambda will be called by dispatch-rules ;; (req) is the request object (case-lambda [(req) (let ([static-path (make-static-path-no-param api-type res-type)]) (if (file-exists? static-path) (html-response (static-file-res static-path)) (let ([res-path (make-source-path-no-param res-type)]) (if (file-exists? res-path) (html-response (resource-processor res-path (write-static-file static-path))) (404-handler api-type)))))] ;; (req id) is (request object . url parameter) [(req id) (let ([static-path (make-static-path-id-param api-type res-type id)]) (if (file-exists? static-path) (html-response (static-file-res static-path)) (let ([res-path (make-source-path-id-param res-type id)]) (if (file-exists? res-path) (html-response (resource-processor res-path (write-static-file static-path))) (404-handler api-type)))))]))) ;;; httpx ;; sends only the requested resource (define (xexpr-file->res file static-write) (string->bytes/utf-8 (static-write (xexpr-file->xml file)))) (define (xexpr-file->xml file) (xexpr->string (read (open-input-file file)))) (define (404-hx) (let ([static-path "static/fragment/not-found.html"]) (html-response (if (file-exists? static-path) (static-file-res static-path) (xexpr-file->res "source/not-found.scm" (write-static-file static-path)))))) (define-values (httpx-app reverse-httpx-uri) (dispatch-rules [("hx" "home") (respond-resource-with-processor 'httpx "root" xexpr-file->res)] [("hx" "settled") (respond-resource-with-processor 'httpx "settled" xexpr-file->res)] [("hx" "settled" (string-arg)) (respond-resource-with-processor 'httpx "settled" xexpr-file->res)] [("hx" "unsettled") (respond-resource-with-processor 'httpx "unsettled" xexpr-file->res)] [("hx" "unsettled" (string-arg)) (respond-resource-with-processor 'httpx "unsettled" xexpr-file->res)] [("hx" "tagged") (respond-resource-with-processor 'httpx "tagged" xexpr-file->res)] [("hx" "tagged" (string-arg)) (respond-resource-with-processor 'httpx "tagged" xexpr-file->res)] [("hx" (string-arg)) (respond-resource-with-processor 'httpx "root" xexpr-file->res)] [else (lambda (req) (404-hx))])) ;;; page-app ;; constructs entire page for each response (define (make-page resource static-write) (string->bytes/utf-8 (static-write (string-append "\n" (fragment->page resource))))) (define (fragment->page resource) (xexpr->string `(html ((lang "en")) ,(read (open-input-file "source/head.scm")) (body ,(read (open-input-file "source/header.scm")) (main ,(read (open-input-file resource))))))) (define (404-page) (let ([static-path "static/page/not-found.html"]) (html-response (if (file-exists? static-path) (static-file-res static-path) (make-page "source/not-found.scm" (write-static-file static-path)))))) (define-values (page-app reverse-page-uri) (dispatch-rules [("") (respond-resource-with-processor 'page "" make-page)] [("home") (respond-resource-with-processor 'page "" make-page)] [("settled") (respond-resource-with-processor 'page "settled" make-page)] [("settled" (string-arg)) (respond-resource-with-processor 'page "settled" make-page)] [("unsettled") (respond-resource-with-processor 'page "unsettled" make-page)] [("unsettled" (string-arg)) (respond-resource-with-processor 'page "unsettled" make-page)] [("tagged") (respond-resource-with-processor 'page "tagged" make-page)] [("tagged" (string-arg)) (respond-resource-with-processor 'page "tagged" make-page)] [((string-arg)) (respond-resource-with-processor 'page "root" make-page)] [else (lambda (req) (404-page))])) ;;; from /static (define url->path/static (make-url->path "static")) (define static-dispatcher (files:make #:url->path (lambda (u) (url->path/static (struct-copy url u [path (cdr (url-path u))]))))) ;; rss feed (define (xml-response content) (response/full 200 #"OK" (current-seconds) #"application/atom+xml; charset=utf-8" '() (list content))) (define (rss-feed request) (xml-response (string->bytes/utf-8 (file->string "source/feed.atom")))) ;;; 404 (define (not-found request) (lambda (req) ((404-page)))) ;;; server (define stop (serve #:dispatch (sequencer:make (filter:make #rx"^/static/" static-dispatcher) (dispatch/servlet #:regexp #rx"^/hx/" httpx-app) (dispatch/servlet #:regexp #rx"^/feed.atom" rss-feed) (dispatch/servlet page-app) (dispatch/servlet not-found)) #:listen-ip "127.0.0.1" #:port 8000)) (with-handlers ([exn:break? (lambda (e) (stop))]) (sync/enable-break never-evt))