guile-toot/rss2toot.scm

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