tapris/rmsrss.scm

;; RSS bot for Pleroma
;;
;; Publishes Stallman's political notes.
;; On the first run will ask for authorization and will spam with posts.
;; Run it with crontab every now and then.

;; The "read" RSS items are stored in the local file "_read_items".
;; The client is serialized to the local file "_client". If there is
;; an error you can regenerate the authorization data by removing the
;; "_client" file.

;; NOTE: if running inside Emacs using geiser: C-c C-e C-l to add "." to the load path.
(use-modules
 (ice-9 rdelim)
 (ice-9 iconv)
 (ice-9 format)
 (ice-9 match)
 (ice-9 textual-ports)
 (rnrs bytevectors)
 (srfi srfi-1)
 (srfi srfi-9)
 (srfi srfi-11)
 (web uri)
 (web response)
 (web client)
 (sxml simple)
 (sxml match)
 ((sxml xpath) #:select (sxpath))
 ;; local
 (tapris client))


(define instance (string->uri "https://satania.space"))
(define rss-uri (string->uri "https://stallman.org/rss/rss.xml"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; AUTHORIZATION

(define (ask-for-code client)
  (let ((u (build-authorize-url client)))
    (format #t "Please visit the following URL to obtain the \
authorization code: ~a\nPlease input the code: " (uri->string u))))

(define (client->list client)
  "Serialize a <client> into a list."
  (match client
    (($ <client> instance id secret token)
     (list (uri->string instance) id secret token))))

(define (list->client ls)
  "Deserialize a <client> from a list."
  (match ls
    ((instance id secret token)
     (make-client (string->uri instance) id secret token))))

(define (new-client instance)
  "Request new authorization data and save it to `_client'."
  (let ((client (register-app instance)))
    (ask-for-code client)
    (let* ((auth-code (read-line))
           (token (get-token client auth-code)))
      (set-client-token! client token)
      (format #t "Trying to verify the token ~a.\n" auth-code)
      (catch 'pleroma (lambda () (verify-credentials client))
        (lambda (keys . args)
          (format #t "Error!\n")
          (for-each (lambda (a) (format #t "-- ~a\n" a)) args)
          (exit 1)))
      (format #t "Verifcation succeeded! Saving the client data locally.\n")
      (let ((port (open-output-file "_client")))
        (write (client->list client) port)
        (close-port port)
        client))))

(define (obtain-client)
  "Try to either obtain existing client authorization data from
_client, or request new authorization data."
  (define (try-read)
    (let* ((port (open-input-file "_client"))
           (client (list->client (read port))))
      (close-port port)
      (catch 'pleroma (lambda () (verify-credentials client))
        (lambda (keys . args)
          (format #t "The existing credentials are not valid! Trying to request new ones..\n")
          (new-client instance)))
      client))
  (catch 'system-error try-read
    (lambda (key . args)
      (match args
        (("open-file" fmt . rest)
         ;; Need to get a new token.
         (new-client instance))
        (_ (apply throw (cons 'system-error args)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RSS

(define-record-type <rss-item>
  (make-rss-item guid title link description date)
  rss-item?
  (guid rss-item-guid)
  (title rss-item-title)
  (link rss-item-link)
  (description rss-item-description)
  (date rss-item-date))

(define (download-sxml uri)
  "Download an XML file from the URI and convert it to SXML."
  (let-values (((res body)
                (http-get uri
                          #:body #f
                          #:version '(1 . 1)
                          #:keep-alive? #f
                          #:headers '()
                          #:decode-body? #t
                          #:streaming? #f)))
    (match (response-code res)
      (200
       (xml->sxml (if (bytevector? body)
                      (bytevector->string body "utf-8")
                      body)
                  #:trim-whitespace? #t))
      (_
       ;; Error
       (throw 'tapris `(("request" . ,uri)
                         ("response-code" . ,(response-code res))
                         ("response-phrase" .
                          ,(response-reason-phrase res))
                         ("response" .
                          ,(if (bytevector? body)
                               (bytevector->string body "utf-8")
                               body))))))))

(define (local-sxml file)
  "Read XML as SXML from a local file."
  (let* ((port (open-input-file file))
         (text (get-string-all port))
         (res (xml->sxml text #:trim-whitespace? #t)))
    (close-port port)
    res))

(define (sxml->rss-item sxml)
  "Parse a single RSS item in SXML as an <rss-item>."
  (sxml-match sxml
    [(item (title ,title) (link ,link) (guid ,guid)
           (description ,desc) (pubDate ,date) . ,rest)
     (make-rss-item
      guid
      title
      link
      desc
      date)]
    [,otherwise (throw 'tapris `((error "sxml->rss-item: match failed") (args . ,sxml)))]))

(define (get-read-items)
  "Reads the list of GUIDs of all the read items from `_read_items'."
  (let* ((port (open-file "_read_items" "a+"))
         (guids (read port)))
    (close-port port)
    (unless (or (list? guids)
                (eof-object? guids))
        (throw 'system-error `((file "_read_items")
                               (contents ,guids)
                               (error "Content is not a list"))))
    (if (eof-object? guids) '() guids)))

(define (set-read-items! guids)
  "Writes the list of GUIDs for all the read items to `_read_items'."
  (let* ((port (open-file "_read_items" "w")))
    (write guids port)
    (close-port port)))

(define (mark-read-items items)
  "Take a list of <rss-item>s, filter out the unread ones, and mark
them as read. Return the list of the unread items."
  (let* ((guids (get-read-items))
         (f (lambda (item) (not (member (rss-item-guid item) guids))))
         (unread-items (filter f items))
         (unread-guids (map rss-item-guid unread-items))
         (total-read-guids (append unread-guids guids)))
    (set-read-items! total-read-guids)
    unread-items))

;; MAIN

(define (display-entry item)
  (format #t "~a: ~a\n" (rss-item-guid item) (rss-item-title item)))

(define (entries) (map sxml->rss-item
                       ((sxpath '(// item))
                        (download-sxml rss-uri))))

(define (main)
  (let* ((client (obtain-client))
         (all-items (entries))
         (items (mark-read-items all-items))
         (publish (lambda (item)
                    (display-entry item)
                    (let ((status (format #f "~a\n<br /><p><a href=\"~a\">~a</a></p>"
                                         (rss-item-description item)
                                         (rss-item-link item)
                                         (rss-item-link item))))
                      (post-status client status)))))
    (format #t "Logged in as ~a.\n" (assoc-ref (verify-credentials client) "acct"))
    (format #t "Publishing new entries...\n")
    (for-each publish (reverse items))))

(main)