Very Small Atom Feed Reader

[Amirouche Boubekki <amirouche@hypermove.net>]

[-- 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* '(("&lt;". "<")
                         ("&gt;" . ">")
                         ("&amp;" . "&")
                         ("&quot;" . "\"")))
  (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