From: Amirouche Boubekki <amirouche@hypermove.net>
To: Guile User <guile-user@gnu.org>
Subject: Very Small Atom Feed Reader
Date: Sun, 06 Mar 2016 15:12:02 +0100 [thread overview]
Message-ID: <0255377f2892d74fa18c2d534c47bf4d@hypermove.net> (raw)
[-- Attachment #1: Type: text/plain, Size: 327 bytes --]
Héllo,
I share with you this small *atom* feed reader which works from command
line. Create a ~/.prime.txt file with the address of atom files you want
to follow and then run the script.
The problem I have is that it fails on wingolog and others but I'm
accepting patches ;)
--
Amirouche ~ amz3 ~ http://www.hyperdev.fr
[-- Attachment #2: main.scm --]
[-- Type: text/plain, Size: 5664 bytes --]
(use-modules (srfi srfi-9))
(use-modules (srfi srfi-19))
(use-modules (srfi srfi-26))
(use-modules (ice-9 match))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 receive))
(use-modules (sxml xpath))
(use-modules (sxml simple))
(use-modules (srfi srfi-1))
(use-modules (web client))
;; XXX: this is required for some reason
(setlocale LC_ALL "")
;;; srfi-999
(define-syntax define-record-type*
(lambda (x)
(define (%id-name name) (string->symbol (string-drop
(string-drop-right
(symbol->string name) 1) 1)))
(define (id-name ctx name)
(datum->syntax ctx (%id-name (syntax->datum name))))
(define (id-append ctx . syms)
(datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
(syntax-case x ()
((_ rname field ...)
(and (identifier? #'rname) (and-map identifier? #'(field ...)))
(with-syntax ((cons (id-append #'rname #'make- (id-name #'rname #'rname)))
(pred (id-append #'rname (id-name #'rname #'rname) #'?))
((getter ...) (map (lambda (f)
(id-append f (id-name #'rname #'rname) #'- f))
#'(field ...))))
#'(define-record-type rname
(cons field ...)
pred
(field getter)
...))))))
;;; sxml procedures
(define (file->sxml filename)
(cdr (xml->sxml (with-input-from-file filename
(lambda ()
(read-string))))))
(define (url-fetch url)
(pk url)
(receive (_ body) (http-get url) body))
;; helpers to turn atom into scheme
(define (sxml->date sxml)
;; FIXME: add support for TZ
(let* ((timestamp (car ((sxpath '(http://www.w3.org/2005/Atom:updated *text*)) sxml)))
(length (string-length "2015-08-13T00:24:00"))
(date (string->date (string-take timestamp length) "~Y-~m-~dT~H:~M:~S")))
;; date))
timestamp))
(define (sxml->feed sxml)
(map (lambda (spec) (cons (car spec) ((cadr spec) sxml)))
`((title ,(sxpath '(http://www.w3.org/2005/Atom:id *text*)))
(updated-at ,sxml->date)
(author ,(sxpath '(http://www.w3.org/2005/Atom:author http://www.w3.org/2005/Atom:name *text*)))
;; XXX: can't retrieve a url node because the attribute axis `equal?``match all the children
;; instead of testing the existance of the provided pair.
;; XXX: the following should match the "href" attribute value of the "alternate" link node
;; (url ,(sxpath '(http://www.w3.org/2005/Atom:link (@ (equal? (rel "alternate"))) @ href *text*)))
(entries ,(sxpath '(http://www.w3.org/2005/Atom:entry))))))
;; borrowed from guix
(define* (string-replace-substring str substr replacement
#:optional
(start 0)
(end (string-length str)))
"Replace all occurrences of SUBSTR in the START--END range
of STR by REPLACEMENT."
(match (string-length substr)
(0
(error "string-replace-substring: empty substring"))
(substr-length
(let loop ((start start)
(pieces (list (substring str 0 start))))
(match (string-contains str substr start end)
(#f
(string-concatenate-reverse
(cons (substring str start) pieces)))
(index
(loop (+ index substr-length)
(cons* replacement
(substring str start index)
pieces))))))))
;; borrowed from haunt
(define (unescape str)
(define *escape-map* '(("<". "<")
(">" . ">")
("&" . "&")
(""" . "\"")))
(fold (lambda (escape str)
(string-replace-substring str (car escape) (cdr escape)))
str
*escape-map*))
(define (sxml->summary sxml)
(define summary->string
(compose cdr xml->sxml unescape car (sxpath '(http://www.w3.org/2005/Atom:summary *text*))))
(catch #true
(lambda () (summary->string sxml))
(lambda (key . args) "")))
(define (sxml->entry sxml)
(map (lambda (spec) (cons (car spec) ((cdr spec) sxml)))
`((title . ,(compose car (sxpath '(http://www.w3.org/2005/Atom:title *text*))))
(url . ,(compose car (sxpath '(http://www.w3.org/2005/Atom:link @ href *text*))))
;; (summary . ,sxml->summary)
(updated-at . ,sxml->date)
;; (uid . ,(compose car (sxpath '(http://www.w3.org/2005/Atom:id *text*))))
)))
(define url->feed (compose sxml->feed cdr xml->sxml url-fetch))
(define (url->entries url)
(map sxml->entry (assoc-ref (url->feed url) 'entries)))
(define (feeds)
(let ((prime.txt (string-join (list (getenv "HOME") ".prime.txt") "/")))
(call-with-input-file prime.txt
(lambda (port)
(let loop ((line (read-line port))
(out '()))
(if (eof-object? line)
out
(loop (read-line port) (cons line out))))))))
(define (sort-entries a b)
(string>? (assoc-ref a 'updated-at) (assoc-ref b 'updated-at)))
(define (format-entry entry)
(format #t "* ~a\n** ~a\n** ~a\n\n"
(assoc-ref entry 'title)
(assoc-ref entry 'url)
(assoc-ref entry 'updated-at)))
(map format-entry (sort (append-map url->entries (feeds)) sort-entries))
;; .prime.txt content
;;
;; http://savannah.gnu.org/news/atom.php?group=guix
;; http://savannah.gnu.org/news/atom.php?group=guile
;; http://dustycloud.org/blog/index.xml
next reply other threads:[~2016-03-06 14:12 UTC|newest]
Thread overview: 7+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-03-06 14:12 Amirouche Boubekki [this message]
2016-03-06 15:13 ` Very Small Atom Feed Reader Luis Felipe López Acevedo
2016-03-13 11:29 ` Amirouche Boubekki
2016-03-06 15:15 ` Nala Ginrut
2016-03-07 9:37 ` Ludovic Courtès
2016-03-13 10:42 ` Alex Kost
2016-03-13 11:20 ` Amirouche Boubekki
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=0255377f2892d74fa18c2d534c47bf4d@hypermove.net \
--to=amirouche@hypermove.net \
--cc=guile-user@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).