254 lines
9.1 KiB
Racket
254 lines
9.1 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)
|
|
|
|
;; 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 #".txt" because source files are not well-formed 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" #".txt") t))
|
|
|
|
(define (make-source-path-id-param t id)
|
|
((make-path-id-param "source" #".txt") 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.txt" (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" (integer-arg)) (respond-resource-with-processor 'httpx "settled" xexpr-file->res)]
|
|
[("hx" "unsettled") (respond-resource-with-processor 'httpx "unsettled" xexpr-file->res)]
|
|
[("hx" "unsettled" (integer-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
|
|
(fragment->page resource))))
|
|
|
|
(define (fragment->page resource)
|
|
(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 (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.txt" (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" (integer-arg)) (respond-resource-with-processor 'page "settled" make-page)]
|
|
[("unsettled") (respond-resource-with-processor 'page "unsettled" make-page)]
|
|
[("unsettled" (integer-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))
|
|
|