176 lines
6.3 KiB
Racket
176 lines
6.3 KiB
Racket
#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))
|
|
|