Initial check-in.

.gitignore

@@ -0,0 +1 @@
+.config.scm

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)))