Browse Source

Fix(*): Module-ize.

main
fshee 2 weeks ago
parent
commit
a27ee06aba
  1. 1
      .gitignore
  2. 15
      dev.rkt
  3. 511
      main.rkt
  4. 2
      makefile
  5. 207
      routes.rkt
  6. 52
      server.rkt
  7. 264
      wp.rkt

1
.gitignore

@ -1 +1,2 @@
dist
*.tgz

15
dev.rkt

@ -0,0 +1,15 @@
#lang racket
(require web-server/servlet)
(require "server.rkt")
(let* ((srv (make-server (string->url "http://localhost:8003")
8000
"etc-fsh-ee-homepage"
14
13))
(cache-refresher (first srv))
(start-server (second srv)))
(thread (lambda () (cache-refresher)))
(start-server))

511
main.rkt

@ -1,18 +1,9 @@
#lang cli
(require web-server/servlet
web-server/servlet-env
json
xml
css-expr
date
(prefix-in http- net/http-easy)
racket/match
racket/string
racket/promise
racket/list)
racket)
;; command line flags
(require "server.rkt")
(flag (port p)
("-p" "--port" "web server will listen on this port")
@ -34,497 +25,11 @@
("-y" "--page-category" "integer of category")
(page-cat (string->number c)))
;; const
(struct link (title href))
(define links
(list
(link "Home" "/")
(link "Quotes" "/quotes")
(link "Links" "/links")
(link "License" "/license")
(link "Search" "/search")
(link "Source" "https://git.fsh.ee/i/etc")))
(define css
(css-expr->css
(css-expr
(*
#:font-size .9rem)
(body
#:font-family monospace
#:line-height 1.4
#:max-width 80ch)
(a
#:text-decoration none)
(blockquote
#:display block
#:position relative
#:padding-left 1rem)
(blockquote:before
#:width 0;
#:content " "
#:position absolute
#:top 0
#:left 0
#:height 100%
#:display block
#:border-style inset
#:border-width 1px)
(pre ((& code)
#:display block
#:position relative
#:padding-left 1rem))
(pre ((& code:before)
#:width 0;
#:content " "
#:position absolute
#:top 0
#:left 0
#:height 100%
#:display block
#:border-style inset
#:border-width 1px))
(code:before code:after
#:content "`")
(blockquote
#:margin-left 0
#:margin-right 0)
(blockquote cite:before
#:content "")
(.comma:after
#:content ", ")
(span:last-of-type
((& .comma)
#:display none))
(@media (and screen (#:max-width 1000PX))
(pre ((& code)
#:max-width 100%
#:overflow-x auto
#:overflow-y hidden
#:-webkit-overflow-scrolling touch))))))
(define (tmpl c)
;; here be dragons (string->xexpr ...)
`(html
(head
(meta ((charset "utf-8")))
(meta ((name "viewport")
(content "width=device-width, initial-scale=1")))
(meta ((name "referrer")
(content "no-referrer-when-downgrade")))
(title ,(content-title c)))
(body ((class "container"))
(style ,css)
(header
(nav
,@(map
(lambda (link)
`(span (a ((href ,(link-href link))) ,(link-title link))
(span ((class "comma")))))
links))
(h1 ,(string->xexpr (string-append "<span>" (content-title c) "</span>"))))
,(if (> (length (content-tags c)) 0)
`(div
,@(map
(lambda (tag)
`(span (a ((href ,(string-append "/subject/" (tag-slug tag)))) ,(tag-title tag))
(span ((class "comma")))))
(content-tags c)))
`(span))
(article ,(string->xexpr (string-append "<div>" (content-desc c) "</div>"))
,(if (> (length (content-posts c)) 0)
`(div
(h2 "Posts")
,@(map
(lambda (post)
`(div (a ((href ,(string-append "/" (content-slug post))))
,(string->xexpr (string-append "<span>" (content-title post) "</span>"))
(br)
(span "PUB " ,(content-pub-fmt post)))
(br)
(br)))
(content-posts c)))
`(span)))
(footer
(pre
(span "PUB " ,(content-pub-fmt c))
(br)
(span "MOD " ,(content-mod-fmt c)))))))
(define date-compiled
(string-trim (current-date-string-iso-8601 #t)
"Z"
#:right? #t))
(define (dummy/date)
date-compiled)
(define (dummy/search-found search-term posts)
(content (string-append "Search results found for '" search-term "'")
(string-append "Found " (number->string (length posts)) " results.")
"search"
"Search"
(dummy/date)
(dummy/date)
'()
posts))
(define (dummy/search-init)
(content
"Search"
"<form action='/search'><input type='text' name='search' autofocus='true'/></form>"
"search"
"Search"
(dummy/date)
(dummy/date)
'()
'()))
(define (dummy/not-found)
(content
"Not Found"
"¯\\_(ツ)_/¯"
"not-found"
"¯\\_(ツ)_/¯"
(dummy/date)
(dummy/date)
'()
'()))
(define (dummy/err)
(content
"Internal Server Error"
"¯\\_(ツ)_/¯"
"internal-server-error"
"¯\\_(ツ)_/¯"
(dummy/date)
(dummy/date)
'()
'()))
;; util
(define (request->string-path req)
(foldl
(lambda (x y) (string-trim y x))
(path->string (url->path (request-uri req)))
(list "/" ".")))
(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))
(define (forever f)
(f)
(forever f))
(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")
(_ (raise (error 'unknown-month)))))
;; ;; always use cache
;; (define (make-cache)
;; (let* ((h (make-hash)))
;; (lambda (key func)
;; (if (hash-has-key? h key)
;; (begin (displayln 'cached)
;; (hash-ref h key))
;; (begin (displayln 'fresh)
;; (let ((res (force func)))
;; (cond ((not (equal? 'not-found res))
;; (hash-set! h key res)))
;; res))))))
;; cache as backup
(define (make-cache)
(make-cache-with-hash
(make-hash)))
(define (make-cache-with-hash h)
(lambda (key p)
(with-handlers ((exn:fail? (lambda (ex)
(cache-attempt h key))))
(let ((res (force p)))
(cond ((not (equal? 'not-found res))
(hash-set! h key res)))
(cache-attempt h key)))))
(define (cache-attempt h key)
(if (hash-has-key? h key)
(hash-ref h key)
'not-found))
;; wp
(struct content
(title desc slug excerpt pub mod tags posts))
;; 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")))
(struct tag
(id title desc slug))
(define (tag->content t)
(if (equal? t 'not-found)
t
(content
(tag-title t)
(tag-desc t)
(tag-slug t)
(tag-desc t)
(dummy/date)
(dummy/date)
'()
'())))
(define (wp/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
wp/make-tag
(second (hash-ref* hash '_embedded 'wp:term)))
'())
'()))
(define (wp/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 (wp/response->entity make-func res)
(if (> (length res) 0)
(make-func (car res))
'not-found))
(define (wp/make-query-params ll)
(foldl
(lambda (val ret)
(let ((sym (first val))
(l (second val)))
(if (> (length l) 0)
(cons (cons sym (string-join (map number->string l) ",")) ret)
ret)))
'()
ll))
;; wp fetchers
(define (wp/fetch-post cache base-url cats slug)
(cache
(string-append "fetch-post:" slug)
(lazy
(wp/response->entity
wp/make-post
(get-json
(full-url
base-url
"/wp-json/wp/v2/posts"
(list (cons 'slug slug)
(cons '_embed "1")
(cons 'categories (string-join (map number->string cats) ","))
(cons 'adjacent "1"))))))))
(define (wp/fetch-post-list cache base-url cats tags)
(cache
(apply string-append (append (list "fetch-post-list:") (map number->string (append cats tags))))
(lazy
(map
wp/make-post
(get-json
(full-url
base-url
"/wp-json/wp/v2/posts"
(wp/make-query-params
(list (list 'categories cats)
(list 'tags tags)))))))))
(define (wp/fetch-post-search cache base-url cats search-term)
(cache
(string-append "fetch-post-search:" search-term)
(lazy
(map
wp/make-post
(get-json
(full-url
base-url
"/wp-json/wp/v2/posts"
(list (cons 'search search-term)
(cons 'categories (string-join (map number->string cats) ",")))))))))
(define (wp/fetch-tag cache base-url slug)
(cache
(string-append "fetch-tag:" slug)
(lazy
(wp/response->entity
wp/make-tag
(get-json
(full-url
base-url
"/wp-json/wp/v2/tags"
(list (cons 'slug slug))))))))
(define (wp/prefetch cache wp cats)
(map (lambda (cat)
(map (lambda (content)
(map (lambda (tag)
(wp/fetch-post-list cache wp (list cat) (list (tag-id (wp/fetch-tag cache wp (tag-slug tag))))))
(content-tags (wp/fetch-post cache wp (list cat) (content-slug content)))))
(wp/fetch-post-list cache wp (list cat) '())))
cats)
cache)
;; server loop
(define (route/root cache wp-url home-content-slug post-cat page-cat req)
(with-handlers ((exn:fail? (lambda (exn) (route/content (dummy/err)))))
(let* ((uri (request->string-path req))
(uri-parts (string-split uri "/")))
(cond ((empty? uri-parts)
(route/content-list
(lambda ()
(wp/fetch-post cache wp-url (list page-cat) home-content-slug))
(lambda ()
(wp/fetch-post-list cache wp-url (list post-cat) (list)))))
((equal? uri-parts (list home-content-slug))
(redirect-to "/"))
((equal? (first uri-parts) "search")
(route/content
(let ((term (query-value 'search (url-query (request-uri req)))))
(if (not (null? term))
(dummy/search-found
term
(let ((res (wp/fetch-post-search cache wp-url (list post-cat page-cat) term)))
(if (equal? res 'not-found)
'()
res)))
(dummy/search-init)))))
((equal? (first uri-parts) "subject")
(let ((tag (wp/fetch-tag cache wp-url (string-trim uri "subject/" #:left? #t))))
(if (equal? tag 'not-found)
(route/content tag)
(route/content-list
(lambda () (tag->content tag))
(lambda () (wp/fetch-post-list cache wp-url (list post-cat) (list (tag-id tag))))))))
(else (route/content (wp/fetch-post cache wp-url (list page-cat post-cat) uri)))))))
;; helpers
(define (route/content c)
(cond ((equal? c 'not-found) (response/xexpr (tmpl (dummy/not-found)) #:code 404))
(else (response/xexpr (tmpl c)))))
(define (route/content-list make-content make-content-list)
(route/content
(let* ((c (make-content))
(clist (make-content-list)))
(if (or (equal? c 'not-found)
(equal? clist 'not-found)
(< (length clist) 1))
(route/content 'not-found)
(content
(content-title c)
(content-desc c)
(content-slug c)
(content-excerpt c)
(content-pub c)
(content-mod c)
(content-tags c)
clist)))))
;; init
(define (cache-refresher wp post-cat page-cat)
(displayln 'prefetch-init)
(with-handlers ((exn:fail? (lambda (exn) (displayln 'prefetch-fail))))
(let ((new-cache (wp/prefetch (make-cache) wp (list post-cat page-cat))))
(displayln 'prefetch-done)
new-cache)))
(define (start-server wp port home-content post-cat page-cat)
(let ((cache (make-cache))
(cache-timeout (* 60 60)))
;; prefill cache with refresh policy
(thread (lambda ()
(forever (lambda ()
(set! cache (cache-refresher wp post-cat page-cat))
(sleep cache-timeout)))))
;; start server
(serve/servlet
(lambda (req)
(route/root cache wp home-content post-cat page-cat req))
#:servlet-regexp #rx""
#:servlet-path "/"
#:port port
#:launch-browser? #f
#:banner? #f
#:listen-ip #f)))
(program (srv)
(start-server (wp) (port) (home) (post-cat) (page-cat)))
(let* ((srv (make-server (wp) (port) (home) (post-cat) (page-cat)))
(cache-refresher (first srv))
(start-server (second srv)))
(thread (lambda () (cache-refresher)))
(start-server)))
(run srv)
(run srv)

2
makefile

@ -1,5 +1,5 @@
dev:
@find . -type f | entr -cr racket -t main.rkt -- -p 8000 -d etc-fsh-ee-homepage -x 14 -y 13 -w "http://localhost:8003"
@find . -type f | entr -cr racket -e '(require "dev.rkt")' -i
prod:
@rm -rf dist

207
routes.rkt

@ -0,0 +1,207 @@
#lang racket
(require web-server/servlet
web-server/servlet-env
json
xml
css-expr
date
(prefix-in http- net/http-easy)
racket/match
racket/string
racket/promise
racket/list)
(require (prefix-in wp: "wp.rkt"))
(provide route-root)
(struct link (title href))
(define links
(list
(link "Home" "/")
(link "Quotes" "/quotes")
(link "Links" "/links")
(link "License" "/license")
(link "Search" "/search")
(link "Source" "https://git.fsh.ee/i/etc")))
(define css
(css-expr->css
(css-expr
(*
#:font-size .9rem)
(body
#:font-family monospace
#:line-height 1.4
#:max-width 80ch)
(a
#:text-decoration none)
(blockquote
#:display block
#:position relative
#:padding-left 1rem)
(blockquote:before
#:width 0;
#:content " "
#:position absolute
#:top 0
#:left 0
#:height 100%
#:display block
#:border-style inset
#:border-width 1px)
(pre ((& code)
#:display block
#:position relative
#:padding-left 1rem))
(pre ((& code:before)
#:width 0;
#:content " "
#:position absolute
#:top 0
#:left 0
#:height 100%
#:display block
#:border-style inset
#:border-width 1px))
(code:before code:after
#:content "`")
(blockquote
#:margin-left 0
#:margin-right 0)
(blockquote cite:before
#:content "")
(.comma:after
#:content ", ")
(span:last-of-type
((& .comma)
#:display none))
(@media (and screen (#:max-width 1000PX))
(pre ((& code)
#:max-width 100%
#:overflow-x auto
#:overflow-y hidden
#:-webkit-overflow-scrolling touch))))))
(define (tmpl c)
;; here be dragons (string->xexpr ...)
`(html
(head
(meta ((charset "utf-8")))
(meta ((name "viewport")
(content "width=device-width, initial-scale=1")))
(meta ((name "X-UA-Compatible")
(content "text/html; charset=utf-8")))
(meta ((name "Content-Type")
(content "text/html; charset=utf-8")))
(meta ((name "robots")
(content "all")))
(meta ((name "referrer")
(content "no-referrer-when-downgrade")))
(title ,(wp:content-title c)))
(body ((class "container"))
(style ,css)
(header
(nav
,@(map
(lambda (link)
`(span (a ((href ,(link-href link))) ,(link-title link))
(span ((class "comma")))))
links))
(h1 ,(string->xexpr (string-append "<span>" (wp:content-title c) "</span>"))))
,(if (> (length (wp:content-tags c)) 0)
`(div
,@(map
(lambda (tag)
`(span (a ((href ,(string-append "/subject/" (wp:tag-slug tag)))) ,(wp:tag-title tag))
(span ((class "comma")))))
(wp:content-tags c)))
`(span))
(article ,(string->xexpr (string-append "<div>" (wp:content-desc c) "</div>"))
,(if (> (length (wp:content-posts c)) 0)
`(div
(h2 "Posts")
,@(map
(lambda (post)
`(div (a ((href ,(string-append "/" (wp:content-slug post))))
,(string->xexpr (string-append "<span>" (wp:content-title post) "</span>"))
(br)
(span "PUB " ,(wp:content-pub-fmt post)))
(br)
(br)))
(wp:content-posts c)))
`(span)))
(footer
(pre
(span "PUB " ,(wp:content-pub-fmt c))
(br)
(span "MOD " ,(wp:content-mod-fmt c)))))))
(define (query-value sym q)
(foldl
(lambda (val ret)
(if (equal? (car val) sym)
(cdr val)
ret))
null
q))
(define (request->string-path req)
(foldl
(lambda (x y) (string-trim y x))
(path->string (url->path (request-uri req)))
(list "/" ".")))
(define (route-root cache wp-url home-content-slug post-cat page-cat req)
(with-handlers ((exn:fail? (lambda (exn)
(displayln exn)
(route-content (wp:dummy-err)))))
(let* ((uri (request->string-path req))
(uri-parts (string-split uri "/")))
(cond ((empty? uri-parts)
(route-content-list
(lambda ()
(wp:fetch-post cache wp-url (list page-cat) home-content-slug))
(lambda ()
(wp:fetch-post-list cache wp-url (list post-cat) (list)))))
((equal? uri-parts (list home-content-slug))
(redirect-to "/"))
((equal? (first uri-parts) "search")
(let* ((term (query-value 'search (url-query (request-uri req))))
(func (if (null? term)
wp:dummy-search-init
(lambda ()
(wp:dummy-search-found
term
(wp:fetch-post-search cache wp-url (list post-cat page-cat) term))))))
(route-content (list (func)))))
((equal? (first uri-parts) "subject")
(let ((tag (wp:fetch-tag cache wp-url (string-trim uri "subject/" #:left? #t))))
(route-content-list
(lambda () (map wp:tag->content tag))
(lambda () (wp:fetch-post-list cache wp-url (list post-cat) (map wp:tag-id tag))))))
(else (route-content (wp:fetch-post cache wp-url (list page-cat post-cat) uri)))))))
;; helpers
(define (route-content c)
(if (empty? c)
(response/xexpr (tmpl (wp:dummy-not-found)) #:code 404)
(response/xexpr (tmpl (car c)))))
(define (route-content-list make-content make-content-list)
(let ((content-list (make-content-list)))
(if (empty? content-list)
(route-content content-list)
(route-content (map (lambda (c)
(wp:content (wp:content-title c)
(wp:content-desc c)
(wp:content-slug c)
(wp:content-excerpt c)
(wp:content-pub c)
(wp:content-mod c)
(wp:content-tags c)
content-list))
(make-content))))))

52
server.rkt

@ -0,0 +1,52 @@
#lang racket
(require web-server/servlet
web-server/servlet-env)
(require (prefix-in router: "routes.rkt")
(prefix-in wp: "wp.rkt"))
(provide make-server)
(define (make-cache)
(let ((h (make-hash)))
(lambda (key promise)
(with-handlers ((exn:fail?
(lambda (exn) (cache-attempt h key))))
(hash-set! h key (force promise))
(cache-attempt h key)))))
(define (cache-attempt h key)
(if (hash-has-key? h key)
(hash-ref h key)
'()))
(define (forever f)
(f)
(forever f))
(define (cache-refresher wp post-cat page-cat)
(displayln 'cache-init)
(let ((cache (make-cache)))
(wp:prefetch cache wp (list post-cat page-cat))
(displayln 'cache-done)
cache))
(define (make-server wp port home-content post-cat page-cat)
(let ((cache (make-cache))
(cache-timeout (* 60 60)))
(list
(lambda ()
(forever
(lambda ()
(set! cache (cache-refresher wp post-cat page-cat))
(sleep cache-timeout))))
(lambda ()
(serve/servlet
(lambda (req)
(router:route-root cache wp home-content post-cat page-cat req))
#:servlet-regexp #rx""
#:servlet-path "/"
#:port port
#:launch-browser? #f
#:listen-ip #f)))))

264
wp.rkt

@ -0,0 +1,264 @@
#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-pub-fmt
content-mod-fmt
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))
(define (dummy-search-init)
(content
"Search"
"<form action='/search'><input type='text' name='search' autofocus='true'/></form>"
"search"
"Search"
(dummy-date)
(dummy-date)
'()
'()))
(define (dummy-not-found)
(content
"Not Found"
"¯\\_(ツ)_/¯"
"not-found"
"¯\\_(ツ)_/¯"
(dummy-date)
(dummy-date)
'()
'()))
(define (dummy-err)
(content
"Internal Server Error"
"¯\\_(ツ)_/¯"
"internal-server-error"
"¯\\_(ツ)_/¯"
(dummy-date)
(dummy-date)
'()
'()))
(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))
;; 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")))
(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)
'()
'()))
(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)))
'())
'()))
(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)))
Loading…
Cancel
Save