202 lines
7.7 KiB
Scheme
202 lines
7.7 KiB
Scheme
(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)))
|