oxaliq.net/oxaliq.net.rkt

257 lines
9.1 KiB
Racket
Raw Normal View History

2023-10-30 20:42:28 +00:00
#lang racket
(require racket/date
(only-in racket/list first second third rest)
(only-in racket/string string-prefix? string-replace)
net/url
2023-10-30 20:42:28 +00:00
xml
web-server/web-server
web-server/servlet-dispatch
web-server/dispatchers/dispatch
2023-10-30 20:42:28 +00:00
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)
2023-11-13 02:35:59 +00:00
racket/runtime-path
2023-10-30 20:42:28 +00:00
web-server/dispatchers/filesystem-map
web-server/http
csv-reading)
2023-10-30 20:42:28 +00:00
;; namespace needed for evaluating read files
(define-namespace-anchor anc)
(define ns (namespace-anchor->namespace anc))
;; it's all html!
2023-10-30 20:42:28 +00:00
(define (html-response content)
(response/full
200
#"OK"
(current-seconds)
TEXT/HTML-MIME-TYPE
'()
(list content)))
2024-01-18 02:01:09 +00:00
;; bound path builders
;; extension is always #".scm" because source files are not racket,
2024-01-18 02:01:09 +00:00
;; 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))
2024-01-18 02:01:09 +00:00
(define (make-source-path-id-param t id)
((make-path-id-param "source" #".scm") t id))
2024-01-18 02:01:09 +00:00
(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)))
2024-01-18 02:01:09 +00:00
(define (make-static-path-id-param api-type t id)
(let ([root-folder
2024-01-18 02:01:09 +00:00
(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)))
2024-01-18 02:01:09 +00:00
(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)]))
2023-10-30 20:42:28 +00:00
;; 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
2024-01-18 02:01:09 +00:00
(lambda (api-type res-type resource-processor)
;; this lambda will be called by dispatch-rules
;; (req) is the request object
(case-lambda
2024-01-18 02:01:09 +00:00
[(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)
2024-01-18 02:01:09 +00:00
(html-response
(resource-processor res-path (write-static-file static-path)))
(404-handler api-type)))))]
;; (req id) is (request object . url parameter)
2024-01-18 02:01:09 +00:00
[(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
2024-01-18 02:01:09 +00:00
(define (xexpr-file->res file static-write)
2023-10-30 20:42:28 +00:00
(string->bytes/utf-8
2024-01-18 02:01:09 +00:00
(static-write (xexpr-file->xml file))))
2023-10-30 20:42:28 +00:00
2024-01-18 02:01:09 +00:00
(define (xexpr-file->xml file)
(xexpr->string (read (open-input-file file))))
2024-01-18 02:01:09 +00:00
(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))))))
2023-10-30 20:42:28 +00:00
(define-values (httpx-app reverse-httpx-uri)
(dispatch-rules
2024-01-18 02:01:09 +00:00
[("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)]
2024-01-18 02:01:09 +00:00
[("hx" "unsettled") (respond-resource-with-processor 'httpx "unsettled" xexpr-file->res)]
[("hx" "unsettled" (string-arg)) (respond-resource-with-processor 'httpx "unsettled" xexpr-file->res)]
2024-01-18 02:01:09 +00:00
[("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))]))
2023-10-30 20:42:28 +00:00
;;; page-app
;; constructs entire page for each response
2024-01-18 02:01:09 +00:00
(define (make-page resource static-write)
2023-10-30 20:42:28 +00:00
(string->bytes/utf-8
2024-01-18 02:01:09 +00:00
(static-write
(string-append
"<!DOCTYPE html>\n"
(fragment->page resource)))))
2024-01-18 02:01:09 +00:00
(define (fragment->page resource)
(xexpr->string
2023-10-30 20:42:28 +00:00
`(html ((lang "en"))
,(read (open-input-file "source/head.scm"))
2023-10-30 20:42:28 +00:00
(body
,(read (open-input-file "source/header.scm"))
2024-01-18 02:01:09 +00:00
(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))))))
2023-10-30 20:42:28 +00:00
(define-values (page-app reverse-page-uri)
(dispatch-rules
2024-01-18 02:01:09 +00:00
[("") (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)]
2024-01-18 02:01:09 +00:00
[("unsettled") (respond-resource-with-processor 'page "unsettled" make-page)]
[("unsettled" (string-arg)) (respond-resource-with-processor 'page "unsettled" make-page)]
2024-01-18 02:01:09 +00:00
[("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))]))
2023-10-30 20:42:28 +00:00
;;; 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
2023-11-09 04:10:28 +00:00
(string->bytes/utf-8 (file->string "source/feed.atom"))))
2023-10-30 20:42:28 +00:00
;;; 404
(define (not-found request)
2024-01-18 02:01:09 +00:00
(lambda (req) ((404-page))))
2023-10-30 20:42:28 +00:00
;;; 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)
2023-10-30 20:42:28 +00:00
(dispatch/servlet page-app)
2024-01-19 02:45:31 +00:00
(dispatch/servlet not-found))
2023-10-30 20:42:28 +00:00
#:listen-ip "127.0.0.1"
#:port 8000))
(with-handlers ([exn:break? (lambda (e)
(stop))])
(sync/enable-break never-evt))