lassik
/
another-planet
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Initial commit

This commit is contained in:
Lassi Kortela 2021-08-21 16:36:23 +03:00
commit 48e45c9f9b
5 changed files with 219 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored Normal file
View File

@ -0,0 +1,2 @@
*.html
/.cache

4
planet-scheme Executable file
View File

@ -0,0 +1,4 @@
#!/bin/sh
set -eu
cd "$(dirname "$0")"
exec csi -R r7rs -I "$PWD" -script planet-scheme.scm "$@"

73
planet-scheme.scm Normal file
View File

@ -0,0 +1,73 @@
(import (scheme base) (srfi 193) (planet))
(define (disp . xs) (for-each display xs) (newline))
(define first car)
(define cache-directory ".cache")
(define base-url "https://planet.scheme.org/")
(define title "Planet Scheme")
(define description
(string-append
"Scheme blog aggregator. Collects blog posts from individuals"
" and projects around the Scheme community."))
(define feeds
(list
(make-feed
"emacsninja"
"Vasilij Schneidermann"
"https://emacsninja.com/scheme.atom")
(make-feed
"idiomdrottning"
"Idiomdrottning"
"https://idiomdrottning.org/blog/programs")))
(define (front-page)
`(html
(@ (lang "en"))
(head
(meta (@ charset "UTF-8"))
(title ,title)
(link (@ (rel "stylesheet") (href "/schemeorg.css")))
(meta (@ (name "viewport")
(content "width=device-width, initial-scale=1")))
(meta (@ (name "description")
(content ,description))))
(body
(h1 ,title)
,@(map
(lambda (entries)
(let ((date (entry-iso-date (first entries))))
`(section
(h2 ,date)
,@(map entry->html entries))))
(planet-group-entries-by-date
(planet-n-newest-entries 10 feeds cache-directory))))))
;;
(define (refresh-cache)
(for-each (lambda (feed)
(disp "Refreshing " (feed-url feed))
(planet-refresh-feed feed cache-directory))
feeds))
(define (generate-from-cache)
(disp "Writing index.html")
(write-html-file "index.html" (front-page)))
(define (main)
(cond ((null? (command-args))
(refresh-cache)
(generate-from-cache))
((and (= 1 (length (command-args)))
(string=? "-n" (first (command-args))))
(generate-from-cache))
(else
(error "Usage: ./planet-scheme [-n]"))))
(main)

3
planet.import.scm Normal file
View File

@ -0,0 +1,3 @@
;; This is a wrapper file for Chicken.
(import (r7rs))
(include "planet.sld")

137
planet.sld Normal file
View File

@ -0,0 +1,137 @@
(define-library (planet)
(export make-feed
feed-id
feed-title
feed-url
entry-title
entry-iso-date
entry->html
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)
(srfi 132)
(srfi 193))
(cond-expand
(chicken
(import (chicken file)
(chicken process-context)
(only (http-client)
with-input-from-request)
(only (sxml-transforms)
SXML->HTML)
(only (traversal) group-by)
(only (atom)
read-atom-feed
feed-entries
entry-updated
entry-title))))
(begin
(define (take-at-most list n)
(let loop ((n n) (new-list '()) (list list))
(if (< n 1) (reverse new-list)
(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))))))
(define (path-append . paths)
(string-join paths "/"))
;;;
(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")))
(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 ()
(let ((temp-file (string-append cache-file ".new")))
(call-with-port
(open-output-file temp-file)
(lambda (output)
(copy-textual-port (current-input-port) output)))
(rename-file temp-file cache-file #t))))))
(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)))
(define (entry-iso-date entry)
(let ((rfc3339 (entry-updated entry)))
(if (and rfc3339 (>= (string-length rfc3339) 10))
(substring rfc3339 0 10)
(error "No date"))))
(define (entry-iso-date<? entry1 entry2)
(string<? (entry-iso-date entry1)
(entry-iso-date entry2)))
(define (entry->html entry)
`(h3 ,(entry-title entry)))
(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))
(define (write-html-file filename sxml)
(let ((new-filename (string-append filename ".new")))
(with-output-to-file new-filename
(lambda ()
(write-string "<!DOCTYPE html>")
(SXML->HTML sxml)
(newline)))
(rename-file new-filename filename #t)))))