oxaliq.net/sorrel.dev.rkt

#lang racket

(require racket/date
         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)
         web-server/dispatchers/filesystem-map
         web-server/http)


(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
                            (build-path "source" type) #".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" type (~a id)) #".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 (404-hx request)
  (html-response (xexpr-file->xml "source/not-found.txt")))


(define-values (httpx-app reverse-httpx-uri)
  (dispatch-rules
   [("hx" "about") (respond-resource-with-processor "about" xexpr-file->xml)]
   [("hx" "home") (respond-resource-with-processor "index" xexpr-file->xml)]
   [("hx" "settleds" (integer-arg)) (respond-resource-with-processor "settleds" xexpr-file->xml)]
   [("hx" "settleds") (respond-resource-with-processor "settleds" xexpr-file->xml)]
   [("hx" "unsettleds" (integer-arg)) (respond-resource-with-processor "unsettleds" xexpr-file->xml)]
   [("hx" "unsettleds") (respond-resource-with-processor "unsettleds" xexpr-file->xml)]
   [("hx" "tagged" (string-arg)) (respond-resource-with-processor "tagged" xexpr-file->xml)]
   [("hx" "tagged") (respond-resource-with-processor "tagged" xexpr-file->xml)]
   [("hx" "this") (respond-resource-with-processor "this" 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"))
            ,(read (open-input-file resource)))))))

(define-values (page-app reverse-page-uri)
  (dispatch-rules
   [("") (respond-resource-with-processor "index" make-page)]
   [("about") (respond-resource-with-processor "about" make-page)]
   [("settleds" (integer-arg)) (respond-resource-with-processor "settleds" make-page)]
   [("settleds") (respond-resource-with-processor "settleds" make-page)]
   [("unsettleds" (integer-arg)) (respond-resource-with-processor "unsettleds" make-page)]
   [("unsettleds") (respond-resource-with-processor "unsettleds" make-page)]
   [("tagged" (string-arg)) (respond-resource-with-processor "tagged" make-page)]
   [("tagged") (respond-resource-with-processor "tagged" make-page)]
   [("this") (respond-resource-with-processor "this" 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)
  (let ([feed-ref "https://sorrel.dev/feed.atom"]
        [update-time (date->string (current-date) (date-display-format 'iso-8601))]
        [homepage "https://sorrel.dev"])
    ;; hard coding for now because reader can't be escaped
    (define content
      `(feed
        ((xmlns "http://www.w3.org/2005/Atom"))
        (title "λ.sorrel.dev")
        (link ((rel "self")
               (href ,feed-ref)))
        (updated ,update-time)
        (author
         (name "sorrel"))
        (id ,homepage)))
    (xml-response
     (string->bytes/utf-8 (string-append "<?xml version=\"1.0\" encoding=\"utf-8\"?>"
                                         (xexpr->string content))))))


;;; 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))