commit 4affedb5163f60c55b5857eb9ba8ea5c3e0a9d92 Author: Ray Miller Date: Sun Aug 4 16:39:04 2024 +0100 Initial check-in. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..0f88245 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +.config.scm diff --git a/rss2toot.scm b/rss2toot.scm new file mode 100644 index 0000000..154fc9d --- /dev/null +++ b/rss2toot.scm @@ -0,0 +1,202 @@ +(use-modules (ice-9 format) + (ice-9 iconv) + (ice-9 rdelim) + ((srfi srfi-1) #:select (concatenate first second filter-map every)) + ((srfi srfi-11) #:select (let-values)) + (rnrs bytevectors) + (gcrypt hash) + (sxml simple) + (sxml xpath) + (web client) + (web response) + (web uri)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Fetch and parse an RSS feed +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (fetch-feed url) + (let-values (((res body) (http-get url))) + (unless (= 200 (response-code res)) + (error (format #f "GET ~a returned unexpected status" url) res)) + (xml->sxml body #:trim-whitespace? #t))) + +(define (get-feed-items feed) + ((sxpath '(rss channel item)) feed)) + +(define (get-item-field field-name item) + (let ((res ((sxpath (list field-name)) item))) + (if (nil? res) + #f + (second (first res))))) + +(define (get-item-tags item) + (filter-map (lambda (attrs) + (let ((term (assoc 'term attrs)) + (scheme (assoc 'scheme attrs))) + (if (and term scheme (string-contains (cadr scheme) "/tags/")) + (string-append "#" (cadr term)) + #f))) + (map cdr ((sxpath '(category @)) item)))) + +(define (fetch-all-feed-items feed-urls) + (concatenate (map (compose get-feed-items fetch-feed) feed-urls))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Read and write the state database +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (parse-database-entry s) + (let ((xs (string-split s #\tab))) + (when (not (= 2 (length xs))) + (error (string-join "Invalid state entry: " s))) + (values (first xs) (string->number (second xs))))) + +(define (parse-state-database db port) + (let loop ((line (read-line port))) + (if (eof-object? line) + db + (let-values (((k v) (parse-database-entry line))) + (hash-set! db k v) + (loop (read-line port)))))) + +(define (read-state-database path) + (define db (make-hash-table)) + (when (file-exists? path) + (call-with-input-file path + (lambda (port) (parse-state-database db port)))) + db) + +(define (unparse-state-database db port) + (hash-for-each (lambda (k v) (format port "~a~/~d~%" k v)) db)) + +;; Write the state database to a temporary file in +;; the same directory, then atomically rename into place. +(define (write-state-database db path) + (let* ((tmp (mkstemp (string-append path ".XXXXXX"))) + (tmp-path (port-filename tmp))) + (unparse-state-database db tmp) + (close-port tmp) + (rename-file tmp-path path))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; URL encoding +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (urlencode-form alist) + (string->bytevector + (string-join (map (lambda (kv) + (let* ((k (car kv)) + (k (if (symbol? k) (symbol->string k) k)) + (v (cdr kv))) + (string-append (uri-encode k) "=" (uri-encode v)))) + alist) + "&") + "ascii")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SHA256 hex +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (bytevector->hex-string bv) + (string-concatenate (map (lambda (x) (format #f "~2,'0x" x)) + (bytevector->u8-list bv)))) + +(define sha256-hex (compose bytevector->hex-string sha256)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Generate and post toot +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Generate the text for a Mastodon status message (toot) for an RSS +;; feed item. If the description contains a link, do not add an additional +;; link to the blog post. This allows for tooting short posts that are +;; simply link shares. +(define (item->toot item) + (let ((title (get-item-field 'title item)) + (description (get-item-field 'description item)) + (link (get-item-field 'link item)) + (tags (string-join (get-item-tags item) " " 'prefix))) + (if (or (string-contains description "http://") + (string-contains description "https://")) + (format #f "~a~%~%~a ~a~%" title description tags) + (format #f "~a~%~%~a ~a~%~a~%" title description tags link)))) + +(define* (post-status api-url token status + #:key (visibility "private") (language "en")) + (let* ((payload (urlencode-form `((status . ,status) + (visibility . ,visibility) + (language . ,language)))) + (idempotency-key (sha256-hex payload))) + ;; TODO: check respones status + (http-post (string-append api-url "/statuses") + #:body payload + #:headers `((Authorization . ,(string-append "Bearer " token)) + (Content-Type . "application/x-www-form-urlencoded") + (Idempotency-Key . ,idempotency-key))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parse the config file +;; +;; The configuration file should be a simple alist with keys: 'api-url, +;; 'access-token, 'feed-urls, and 'db-path +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define config-string-keys '(api-url access-token db-path)) +(define config-string-list-keys '(feed-urls)) + +(define (validate-config c) + (unless (and (list? c) (every pair? c)) + (error "Configuration error: configuration should be an association list")) + (for-each + (lambda (k) + (unless (assq-ref c k) + (error (format #f "Configuration error: missing required key ~a" k)))) + (append config-string-keys config-string-list-keys)) + (for-each + (lambda (k) + (unless (string? (assq-ref c k)) + (error (format #f "Configuration error: ~a should be a string" k)))) + config-string-keys) + (for-each + (lambda (k) + (unless (and (list? (assq-ref c k)) (every string? (assq-ref c k))) + (error (format #f "Configuration error: ~a should be a list of strings" k)))) + config-string-list-keys)) + +(define (read-config path) + (let ((config (call-with-input-file path read))) + (validate-config config) + config)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Fetch feeds, post toots, +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (process-feeds config) + (let* ((db-path (assq-ref config 'db-path)) + (db (read-state-database db-path)) + (now (current-time))) + (for-each + (lambda (item) + (let ((guid (get-item-field 'guid item))) + (unless (hash-ref db guid) + ;; TODO: actually post the toot + (format #t "Posting toot!~%~%~a==========~%" (item->toot item)) + (hash-set! db guid now)))) + (fetch-all-feed-items (assq-ref config 'feed-urls))) + (write-state-database db db-path))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Initialize the state database +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (initialize config) + (let ((db-path (assq-ref config 'db-path)) + (db (make-hash-table)) + (now (current-time))) + (for-each + (lambda (item) + (hash-set! db (get-item-field 'guid item) now)) + (fetch-all-feed-items (assq-ref config 'feed-urls))) + (write-state-database db db-path)))