another-planet/planet.sld

191 lines
6.0 KiB
Plaintext
Raw Permalink Normal View History

2021-08-21 09:36:23 -04:00
(define-library (planet)
(export make-feed
feed-id
feed-title
feed-url
2021-08-21 10:46:08 -04:00
feed-cache-file
feed-cached?
2021-08-21 10:10:34 -04:00
entry-author
2021-08-21 09:36:23 -04:00
entry-title
2021-08-21 10:10:34 -04:00
entry-content-xhtml
2021-08-21 09:36:23 -04:00
entry-iso-date
2021-08-21 10:10:34 -04:00
entry-us-english-date
2021-08-21 10:23:13 -04:00
entry-english-year-and-month
2021-08-21 09:36:23 -04:00
planet-refresh-feed
planet-all-entries-ever
planet-n-newest-entries
planet-group-entries-by-date
write-html-file)
(import (scheme base)
(scheme file)
(scheme write)
(srfi 1)
(srfi 13)
2021-08-21 09:48:10 -04:00
(srfi 132))
2021-08-21 09:36:23 -04:00
(cond-expand
(chicken
2021-08-21 09:39:33 -04:00
(import (only (chicken file)
create-directory
rename-file)
2021-08-21 09:36:23 -04:00
(only (http-client)
with-input-from-request)
(only (sxml-transforms)
SXML->HTML)
2021-08-21 09:39:33 -04:00
(only (traversal)
group-by)
2021-08-21 09:36:23 -04:00
(only (atom)
2021-08-21 10:10:34 -04:00
content-xhtml
entry-author
entry-content
entry-title
2021-08-21 09:36:23 -04:00
entry-updated
2021-08-21 10:10:34 -04:00
feed-entries
read-atom-feed))))
2021-08-21 09:36:23 -04:00
(begin
(define (take-at-most list n)
(let loop ((n n) (new-list '()) (list list))
2021-08-21 10:22:41 -04:00
(if (or (null? list) (< n 1)) (reverse new-list)
2021-08-21 09:36:23 -04:00
(loop (- n 1) (cons (car list) new-list) (cdr list)))))
(define (disp . xs)
(for-each display xs)
(newline))
(define (edisp . xs)
(parameterize ((current-output-port (current-error-port)))
(apply disp xs)))
(define (writeln x)
(write x)
(newline))
(define (copy-binary-port input output)
(let ((buffer (make-bytevector (* 64 1024) 0)))
(let loop ()
(let ((n-read (read-bytevector! buffer input)))
(if (eof-object? n-read) #t
(begin (write-bytevector buffer output 0 n-read)
(loop)))))))
(define (copy-textual-port input output)
(define buffer-size (* 64 1024))
(let loop ()
(let ((chunk (read-string buffer-size input)))
(or (eof-object? chunk)
(begin (write-string chunk output)
(loop))))))
2021-08-21 09:48:10 -04:00
(define (supersede-text-file filename thunk)
(let ((new-filename (string-append filename ".new")))
(with-output-to-file new-filename thunk)
(rename-file new-filename filename #t)))
2021-08-21 09:36:23 -04:00
(define (path-append . paths)
(string-join paths "/"))
2021-08-21 10:23:13 -04:00
(define english-month-names
(vector
"January"
"February"
"March"
"April"
"May"
"June"
"July"
"August"
"September"
"October"
"November"
"December"))
2021-08-21 09:36:23 -04:00
;;;
(define-record-type feed
(make-feed id title url)
feed?
(id feed-id)
(title feed-title)
(url feed-url))
(define (feed-cache-file feed cache-directory)
(path-append cache-directory (string-append (feed-id feed) ".xml")))
2021-08-21 10:46:08 -04:00
(define (feed-cached? feed cache-directory)
(file-exists? (feed-cache-file feed cache-directory)))
2021-08-21 09:36:23 -04:00
(define (planet-refresh-feed feed cache-directory)
(let ((cache-file (feed-cache-file feed cache-directory)))
(create-directory cache-directory)
(with-input-from-request
(feed-url feed)
#f
(lambda ()
2021-08-21 09:48:10 -04:00
(supersede-text-file
cache-file (lambda ()
(copy-textual-port (current-input-port)
(current-output-port))))))))
2021-08-21 09:36:23 -04:00
(define (read-feed-from-cache feed cache-directory)
(let ((cache-file (feed-cache-file feed cache-directory)))
(call-with-port (open-binary-input-file cache-file) read-atom-feed)))
2021-08-21 10:10:34 -04:00
(define (entry-content-xhtml entry)
(content-xhtml (entry-content entry)))
2021-08-21 10:23:13 -04:00
(define (entry-rfc3339-digits n entry)
2021-08-21 09:36:23 -04:00
(let ((rfc3339 (entry-updated entry)))
2021-08-21 10:23:13 -04:00
(if (and rfc3339 (>= (string-length rfc3339) n))
(substring rfc3339 0 n)
2021-08-21 09:36:23 -04:00
(error "No date"))))
2021-08-21 10:23:13 -04:00
(define (entry-iso-date entry) (entry-rfc3339-digits 10 entry))
(define (entry-iso-month entry) (entry-rfc3339-digits 7 entry))
(define (entry-y-m-d-integers entry)
2021-08-21 10:10:34 -04:00
(let* ((yyyy-mm-dd (entry-iso-date entry))
2021-08-21 10:23:13 -04:00
(year (string->number (substring yyyy-mm-dd 0 4)))
2021-08-21 10:10:34 -04:00
(month (string->number (substring yyyy-mm-dd 5 7)))
2021-08-21 10:23:13 -04:00
(day (string->number (substring yyyy-mm-dd 8 10))))
(values year month day)))
(define (entry-us-english-date entry)
(let-values (((year month day) (entry-y-m-d-integers entry)))
(let ((month-name (vector-ref english-month-names (- month 1))))
(string-append
(number->string day) " " month-name " " (number->string year)))))
(define (entry-english-year-and-month entry)
(let-values (((year month _) (entry-y-m-d-integers entry)))
(let ((month-name (vector-ref english-month-names (- month 1))))
(string-append month-name " " (number->string year)))))
2021-08-21 10:10:34 -04:00
2021-08-21 09:36:23 -04:00
(define (entry-iso-date<? entry1 entry2)
(string<? (entry-iso-date entry1)
(entry-iso-date entry2)))
(define (planet-all-entries-ever feeds cache-directory)
(let ((entries (append-map feed-entries
(map (lambda (feed)
(read-feed-from-cache
feed cache-directory))
feeds))))
(reverse (list-stable-sort entry-iso-date<? entries))))
(define (planet-n-newest-entries n feeds cache-directory)
(take-at-most (planet-all-entries-ever feeds cache-directory) n))
(define (planet-group-entries-by-date entries)
(group-by entry-iso-date entries))
2021-08-21 10:23:13 -04:00
(define (planet-group-entries-by-month entries)
(group-by entry-iso-month entries))
2021-08-21 09:36:23 -04:00
(define (write-html-file filename sxml)
2021-08-21 09:48:10 -04:00
(supersede-text-file
filename (lambda ()
(write-string "<!DOCTYPE html>")
(SXML->HTML sxml)
(newline))))))