A blog and other things. https://etc.fsh.ee/
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 

296 lines
7.1 KiB

#lang racket
(require web-server/servlet
json
date
(prefix-in http- net/http-easy))
(provide fetch-post
fetch-post-list
fetch-post-search
fetch-tag
prefetch
dummy-search-found
dummy-search-init
dummy-not-found
dummy-err
content
content-title
content-desc
content-slug
content-excerpt
content-pub
content-mod
content-tags
content-posts
content-prev
content-next
content-cats
content-pub-fmt
content-mod-fmt
content-is
tag->content
tag
tag-id
tag-title
tag-desc
tag-slug)
(define (dummy-search-found search-term posts)
(content (string-append "Search r/esults found for '" search-term "'")
(string-append "Found " (number->string (length posts)) " results.")
"search"
"Search"
(dummy-date)
(dummy-date)
'()
posts
#f
#f
'()))
(define (dummy-search-init)
(content
"Search"
"<form action='/search'><input type='text' name='search' autofocus='true'/></form>"
"search"
"Search"
(dummy-date)
(dummy-date)
'()
'()
#f
#f
'()))
(define (dummy-not-found)
(content
"Not Found"
"¯\\_(ツ)_/¯"
"not-found"
"¯\\_(ツ)_/¯"
(dummy-date)
(dummy-date)
'()
'()
#f
#f
'()))
(define (dummy-err)
(content
"Internal Server Error"
"¯\\_(ツ)_/¯"
"internal-server-error"
"¯\\_(ツ)_/¯"
(dummy-date)
(dummy-date)
'()
'()
#f
#f
'()))
(define date-compiled
(string-trim (current-date-string-iso-8601 #t)
"Z"
#:right? #t))
(define (dummy-date)
date-compiled)
(define (string-pad-left target-length pad-with input)
(if (> target-length (string-length input))
(string-pad-left target-length pad-with (string-append pad-with input))
input))
(define (number->month n)
(match n
(1 "JAN")
(2 "FEB")
(3 "MAR")
(4 "APR")
(5 "MAY")
(6 "JUN")
(7 "JUL")
(8 "AUG")
(9 "SEP")
(10 "OCT")
(11 "NOV")
(12 "DEC")))
(define (get-json url (timeout 2))
(bytes->jsexpr
(http-response-body
(http-get url #:timeouts (http-make-timeout-config #:request timeout)))))
(define (hash-ref* hash . selectors)
(foldl (lambda (val ret)
(hash-ref ret val))
hash
selectors))
(define (full-url base-url path query)
(struct-copy
url
base-url
(path (url-path (string->url path)))
(query query)))
(define (query-value sym q)
(foldl
(lambda (val ret)
(if (equal? (car val) sym)
(cdr val)
ret))
null
q))
(struct content
(title desc slug excerpt pub mod tags posts prev next cats))
;; methods
(define (content-pub-fmt c)
(content-format-date (content-pub c)))
(define (content-mod-fmt c)
(content-format-date (content-mod c)))
(define (content-format-date datestr)
(let ((d (iso-8601-date-string->date (string-append datestr ".000Z"))))
(string-append
(string-pad-left 2 "0" (number->string (date-day d)))
(number->month (date-month d))
(number->string (date-year d))
" "
(string-pad-left 2 "0" (number->string (date-hour d)))
(string-pad-left 2 "0" (number->string (date-minute d)))
"Z")))
(define (content-is c cat)
(foldl (lambda (val ret)
(if (equal? val cat)
#t
ret))
#f
(content-cats c)))
(struct tag
(id title desc slug))
(define (tag->content t)
(content
(tag-title t)
(tag-desc t)
(tag-slug t)
(tag-desc t)
(dummy-date)
(dummy-date)
'()
'()
#f
#f
'()))
(define (make-post hash)
(content
(hash-ref* hash 'title 'rendered)
(hash-ref* hash 'content 'rendered)
(hash-ref* hash 'slug)
(hash-ref* hash 'excerpt 'rendered)
(hash-ref* hash 'date_gmt)
(hash-ref* hash 'modified_gmt)
(if (hash-has-key? hash '_embedded)
(map make-tag (second (hash-ref* hash '_embedded 'wp:term)))
'())
'()
(if (hash-has-key? hash 'prev)
(make-post (hash-ref* hash 'prev))
#f)
(if (hash-has-key? hash 'next)
(make-post (hash-ref* hash 'next))
#f)
(hash-ref* hash 'categories)))
(define (make-tag hash)
(tag
(hash-ref* hash 'id)
(hash-ref* hash 'name)
(if (hash-has-key? hash 'description)
(string-append "<p>" (hash-ref* hash 'description) "</p>")
"")
(hash-ref* hash 'slug)))
(define (response->entity make-func res)
(map make-func res))
(define (make-query-params ll)
(foldl (lambda (l qp)
(let ((sym (first l))
(val (second l)))
(if (list? val)
(if (> (length val) 0)
(cons (cons sym (string-join (map number->string val) ",")) qp)
qp)
(cons (cons sym val) qp))))
'()
ll))
;; wp fetchers
(define (api base-url ent-type params)
(let* ((ent (match ent-type
('post (list make-post
"/wp-json/wp/v2/posts"))
('tag (list make-tag
"wp-json/wp/v2/tags"))
(_ (raise (error 'unknown-entity)))))
(make-func (first ent))
(path (second ent))
(url (full-url base-url path (make-query-params params))))
(response->entity make-func (get-json url))))
(define (fetch-post cache base-url cats slug)
(cache
(string-append "fetch-post:" slug)
(lazy (api base-url
'post
(list (list 'slug slug)
(list '_embed "1")
(list 'categories (string-join (map number->string cats) ","))
(list 'adjacent "1"))))))
(define (fetch-post-list cache base-url cats tags)
(cache
(apply string-append (append (list "fetch-post-list:") (map number->string (append cats tags))))
(lazy (api base-url 'post
(list (list 'categories cats)
(list 'tags tags))))))
(define (fetch-post-search cache base-url cats search-term)
(cache
(string-append "fetch-post-search:" search-term)
(lazy (api base-url 'post
(list (list 'search search-term)
(list 'categories (string-join (map number->string cats) ",")))))))
(define (fetch-tag cache base-url slug)
(cache
(string-append "fetch-tag:" slug)
(lazy (api base-url 'tag (list (list 'slug slug))))))
;; prefetch
(define (prefetch cache wp cats)
(map (lambda (cat) (prefetch-content-list cache wp cat)) cats))
(define (prefetch-content-list cache wp cat)
(map (lambda (content)
(prefetch-content cache wp cat content))
(fetch-post-list cache wp (list cat) (list))))
(define (prefetch-content cache wp cat content)
(map (lambda (content)
(map (lambda (tag) (prefetch-tag cache wp tag))
(content-tags content)))
(fetch-post cache wp (list cat) (content-slug content))))
(define (prefetch-tag cache wp tag)
(fetch-tag cache wp (tag-slug tag)))