From 48e45c9f9b292b8c8f86574dc56b8d0300e2e9c7 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 21 Aug 2021 16:36:23 +0300 Subject: [PATCH] Initial commit --- .gitignore | 2 + planet-scheme | 4 ++ planet-scheme.scm | 73 ++++++++++++++++++++++++ planet.import.scm | 3 + planet.sld | 137 ++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 219 insertions(+) create mode 100644 .gitignore create mode 100755 planet-scheme create mode 100644 planet-scheme.scm create mode 100644 planet.import.scm create mode 100644 planet.sld diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..691abd4 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*.html +/.cache diff --git a/planet-scheme b/planet-scheme new file mode 100755 index 0000000..6c4aa85 --- /dev/null +++ b/planet-scheme @@ -0,0 +1,4 @@ +#!/bin/sh +set -eu +cd "$(dirname "$0")" +exec csi -R r7rs -I "$PWD" -script planet-scheme.scm "$@" diff --git a/planet-scheme.scm b/planet-scheme.scm new file mode 100644 index 0000000..f503d71 --- /dev/null +++ b/planet-scheme.scm @@ -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) diff --git a/planet.import.scm b/planet.import.scm new file mode 100644 index 0000000..821acc7 --- /dev/null +++ b/planet.import.scm @@ -0,0 +1,3 @@ +;; This is a wrapper file for Chicken. +(import (r7rs)) +(include "planet.sld") diff --git a/planet.sld b/planet.sld new file mode 100644 index 0000000..c5f0f44 --- /dev/null +++ b/planet.sld @@ -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-datehtml 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") + (SXML->HTML sxml) + (newline))) + (rename-file new-filename filename #t)))))