Move stuff to module dir.

1 files changed, 53 insertions, 0 deletions

diff --git a/module/rss-filter/feed-handler.scm b/module/rss-filter/feed-handler.scm
new file mode 100644
index 0000000..eef1ca7
--- /dev/null
+++ b/module/rss-filter/feed-handler.scm
@@ -0,0 +1,53 @@
+(define-module (rss-filter feed-handler)
+  :use-module (rnrs records syntactic)
+  :use-module (sxml simple)
+  :use-module (sxml transform)
+  :use-module (sxml xpath)
+  :export (make-feed feed-url feed-transformer
+                     parse-rss filter-tree))
+
+(define-record-type feed
+  (fields url transformer))
+
+
+(define rss-namespaces
+  '((rdf . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
+    (dc . "http://purl.org/dc/elements/1.1/")
+    (syn . "http://purl.org/rss/1.0/modules/syndication/")
+    (rss . "http://purl.org/rss/1.0/")
+    (atom . "http://www.w3.org/2005/Atom")
+    (#f . "http://purl.org/rss/1.0/")
+    ))
+
+(define (parse-rss port)
+  (xml->sxml port #:namespaces rss-namespaces))
+
+(define (namespaces->sxml namespaces)
+  (map (lambda (namespace)
+         (list (string->symbol
+                (if (not (car namespace))
+                    "xmlns"
+                    (string-append "xmlns:" (symbol->string (car namespace)))))
+               (cdr namespace)))
+       namespaces))
+
+
+(define (filter-tree transformers tree)
+  (pre-post-order
+   tree
+   `(,@transformers
+     (rdf:RDF . ,(lambda (tag . children)
+                   (cond (((sxpath '(@)) (cons tag children))
+                          (negate null?)
+                          => (lambda (attributes)
+                               (write attributes (current-error-port)) (newline (current-error-port))
+                               `(,tag
+                                 (@ ,@(namespaces->sxml rss-namespaces)
+                                    ,@(cdar attributes))
+                                 ,@(cdr children))))
+                         (else
+                          `(,tag (@ ,@(namespaces->sxml rss-namespaces))
+                                 ,@(cdr children))))))
+     (*text* . ,(lambda (_ x . xs) x))
+     (*default* . ,(lambda (item  . children)
+                     (cons item children))))) )