#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) (define-namespace-anchor anc) (define ns (namespace-anchor->namespace anc)) (define (html-response content) (response/full 200 #"OK" (current-seconds) TEXT/HTML-MIME-TYPE '() (list content))) ;; 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 (type resource-processor) (case-lambda [(req) (let ([res-path (path-add-extension (if (and (non-empty-string? type) (not (eq? type "root"))) (build-path "source" type "index") (build-path "source" "index" )) #".txt")]) (if (file-exists? res-path) (html-response (resource-processor res-path)) (html-response (resource-processor "source/not-found.txt"))))] [(req id) (let ([res-path (path-add-extension (build-path "source" (if (eq? type "root") (if (eq? id "") ;; if "root/" something weird has happened "index" ;; allows for loading "/this" and other root resources (~a id)) (if ;; if "type/" id will be an empty string (or (not (string? id)) (non-empty-string? id)) (build-path type (~a id)) ;; and should return index for that type (build-path type "index")))) #".txt")]) (if (file-exists? res-path) (html-response (resource-processor res-path)) (html-response (resource-processor "source/not-found.txt"))))]))) ;;; httpx ;; sends only the requested resource (define (xexpr-file->xml file) (string->bytes/utf-8 (xexpr->string (read (open-input-file file))))) (define (build-index res) (let* ([table (csv->list (open-input-file (path-add-extension (build-path "data" res) #".csv")))] [make-index (read (open-input-file "source/make-index.txt"))] [index ((eval make-index ns) res (rest table))]) (lambda (req) (if (equal? res "tagged") '() (html-response (string->bytes/utf-8 (xexpr->string index))))))) (define (404-hx request) (html-response (xexpr-file->xml "source/not-found.txt"))) (define-values (httpx-app reverse-httpx-uri) (dispatch-rules [("hx" "home") (respond-resource-with-processor "root" xexpr-file->xml)] [("hx" "settled") (build-index "settled")] [("hx" "settled" (integer-arg)) (respond-resource-with-processor "settled" xexpr-file->xml)] [("hx" "unsettled") (build-index "unsettled")] [("hx" "unsettled" (integer-arg)) (respond-resource-with-processor "unsettled" xexpr-file->xml)] [("hx" "tagged") (respond-resource-with-processor "tagged" xexpr-file->xml)] [("hx" "tagged" (string-arg)) (respond-resource-with-processor "tagged" xexpr-file->xml)] [("hx" (string-arg)) (respond-resource-with-processor "root" xexpr-file->xml)] [else 404-hx])) ;;; page-app ;; constructs entire page for each response (define (make-page resource) (string->bytes/utf-8 (xexpr->string `(html ((lang "en")) ,(read (open-input-file "source/head.txt")) (body ,(read (open-input-file "source/header.txt")) (main ,(read (open-input-file resource)))))))) (define-values (page-app reverse-page-uri) (dispatch-rules [("") (respond-resource-with-processor "" make-page)] [("home") (respond-resource-with-processor "" make-page)] [("settled") (respond-resource-with-processor "settled" make-page)] [("settled" (integer-arg)) (respond-resource-with-processor "settled" make-page)] [("unsettled") (respond-resource-with-processor "unsettled" make-page)] [("unsettled" (integer-arg)) (respond-resource-with-processor "unsettled" make-page)] [("tagged") (respond-resource-with-processor "tagged" make-page)] [("tagged" (string-arg)) (respond-resource-with-processor "tagged" make-page)] [((string-arg)) (respond-resource-with-processor "root" make-page)] [else not-found])) ;;; 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) (html-response (make-page "source/not-found.txt"))) ;;; 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))