rmsrss.scm 6.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210
  1. ;; RSS bot for Pleroma
  2. ;;
  3. ;; Publishes Stallman's political notes.
  4. ;; On the first run will ask for authorization and will spam with posts.
  5. ;; Run it with crontab every now and then.
  6. ;; The "read" RSS items are stored in the local file "_read_items".
  7. ;; The client is serialized to the local file "_client". If there is
  8. ;; an error you can regenerate the authorization data by removing the
  9. ;; "_client" file.
  10. ;; NOTE: if running inside Emacs using geiser: C-c C-e C-l to add "." to the load path.
  11. (use-modules
  12. (ice-9 rdelim)
  13. (ice-9 iconv)
  14. (ice-9 format)
  15. (ice-9 match)
  16. (ice-9 textual-ports)
  17. (rnrs bytevectors)
  18. (srfi srfi-1)
  19. (srfi srfi-9)
  20. (srfi srfi-11)
  21. (web uri)
  22. (web response)
  23. (web client)
  24. (sxml simple)
  25. (sxml match)
  26. ((sxml xpath) #:select (sxpath))
  27. ;; local
  28. (tapris client))
  29. (define instance (string->uri "https://satania.space"))
  30. (define rss-uri (string->uri "https://stallman.org/rss/rss.xml"))
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32. ;;; AUTHORIZATION
  33. (define (ask-for-code client)
  34. (let ((u (build-authorize-url client)))
  35. (format #t "Please visit the following URL to obtain the \
  36. authorization code: ~a\nPlease input the code: " (uri->string u))))
  37. (define (client->list client)
  38. "Serialize a <client> into a list."
  39. (match client
  40. (($ <client> instance id secret token)
  41. (list (uri->string instance) id secret token))))
  42. (define (list->client ls)
  43. "Deserialize a <client> from a list."
  44. (match ls
  45. ((instance id secret token)
  46. (make-client (string->uri instance) id secret token))))
  47. (define (new-client instance)
  48. "Request new authorization data and save it to `_client'."
  49. (let ((client (register-app instance)))
  50. (ask-for-code client)
  51. (let* ((auth-code (read-line))
  52. (token (get-token client auth-code)))
  53. (set-client-token! client token)
  54. (format #t "Trying to verify the token ~a.\n" auth-code)
  55. (catch 'pleroma (lambda () (verify-credentials client))
  56. (lambda (keys . args)
  57. (format #t "Error!\n")
  58. (for-each (lambda (a) (format #t "-- ~a\n" a)) args)
  59. (exit 1)))
  60. (format #t "Verifcation succeeded! Saving the client data locally.\n")
  61. (let ((port (open-output-file "_client")))
  62. (write (client->list client) port)
  63. (close-port port)
  64. client))))
  65. (define (obtain-client)
  66. "Try to either obtain existing client authorization data from
  67. _client, or request new authorization data."
  68. (define (try-read)
  69. (let* ((port (open-input-file "_client"))
  70. (client (list->client (read port))))
  71. (close-port port)
  72. (catch 'pleroma (lambda () (verify-credentials client))
  73. (lambda (keys . args)
  74. (format #t "The existing credentials are not valid! Trying to request new ones..\n")
  75. (new-client instance)))
  76. client))
  77. (catch 'system-error try-read
  78. (lambda (key . args)
  79. (match args
  80. (("open-file" fmt . rest)
  81. ;; Need to get a new token.
  82. (new-client instance))
  83. (_ (apply throw (cons 'system-error args)))))))
  84. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  85. ;; RSS
  86. (define-record-type <rss-item>
  87. (make-rss-item guid title link description date)
  88. rss-item?
  89. (guid rss-item-guid)
  90. (title rss-item-title)
  91. (link rss-item-link)
  92. (description rss-item-description)
  93. (date rss-item-date))
  94. (define (download-sxml uri)
  95. "Download an XML file from the URI and convert it to SXML."
  96. (let-values (((res body)
  97. (http-get uri
  98. #:body #f
  99. #:version '(1 . 1)
  100. #:keep-alive? #f
  101. #:headers '()
  102. #:decode-body? #t
  103. #:streaming? #f)))
  104. (match (response-code res)
  105. (200
  106. (xml->sxml (if (bytevector? body)
  107. (bytevector->string body "utf-8")
  108. body)
  109. #:trim-whitespace? #t))
  110. (_
  111. ;; Error
  112. (throw 'tapris `(("request" . ,uri)
  113. ("response-code" . ,(response-code res))
  114. ("response-phrase" .
  115. ,(response-reason-phrase res))
  116. ("response" .
  117. ,(if (bytevector? body)
  118. (bytevector->string body "utf-8")
  119. body))))))))
  120. (define (local-sxml file)
  121. "Read XML as SXML from a local file."
  122. (let* ((port (open-input-file file))
  123. (text (get-string-all port))
  124. (res (xml->sxml text #:trim-whitespace? #t)))
  125. (close-port port)
  126. res))
  127. (define (sxml->rss-item sxml)
  128. "Parse a single RSS item in SXML as an <rss-item>."
  129. (sxml-match sxml
  130. [(item (title ,title) (link ,link) (guid ,guid)
  131. (description ,desc) (pubDate ,date) . ,rest)
  132. (make-rss-item
  133. guid
  134. title
  135. link
  136. desc
  137. date)]
  138. [,otherwise (throw 'tapris `((error "sxml->rss-item: match failed") (args . ,sxml)))]))
  139. (define (get-read-items)
  140. "Reads the list of GUIDs of all the read items from `_read_items'."
  141. (let* ((port (open-file "_read_items" "a+"))
  142. (guids (read port)))
  143. (close-port port)
  144. (unless (or (list? guids)
  145. (eof-object? guids))
  146. (throw 'system-error `((file "_read_items")
  147. (contents ,guids)
  148. (error "Content is not a list"))))
  149. (if (eof-object? guids) '() guids)))
  150. (define (set-read-items! guids)
  151. "Writes the list of GUIDs for all the read items to `_read_items'."
  152. (let* ((port (open-file "_read_items" "w")))
  153. (write guids port)
  154. (close-port port)))
  155. (define (mark-read-items items)
  156. "Take a list of <rss-item>s, filter out the unread ones, and mark
  157. them as read. Return the list of the unread items."
  158. (let* ((guids (get-read-items))
  159. (f (lambda (item) (not (member (rss-item-guid item) guids))))
  160. (unread-items (filter f items))
  161. (unread-guids (map rss-item-guid unread-items))
  162. (total-read-guids (append unread-guids guids)))
  163. (set-read-items! total-read-guids)
  164. unread-items))
  165. ;; MAIN
  166. (define (display-entry item)
  167. (format #t "~a: ~a\n" (rss-item-guid item) (rss-item-title item)))
  168. (define (entries) (map sxml->rss-item
  169. ((sxpath '(// item))
  170. (download-sxml rss-uri))))
  171. (define (main)
  172. (let* ((client (obtain-client))
  173. (all-items (entries))
  174. (items (mark-read-items all-items))
  175. (publish (lambda (item)
  176. (display-entry item)
  177. (let ((status (format #f "~a\n<br /><p><a href=\"~a\">~a</a></p>"
  178. (rss-item-description item)
  179. (rss-item-link item)
  180. (rss-item-link item))))
  181. (post-status client status)))))
  182. (format #t "Logged in as ~a.\n" (assoc-ref (verify-credentials client) "acct"))
  183. (format #t "Publishing new entries...\n")
  184. (for-each publish (reverse items))))
  185. (main)