Initial commit.

1 files changed, 58 insertions, 0 deletions

diff --git a/main.scm b/main.scm
new file mode 100755
index 0000000..d0459b2
--- /dev/null
+++ b/main.scm
@@ -0,0 +1,58 @@
+#!/usr/bin/guile \
+-e main -s
+!#
+
+(use-modules
+ (web client)
+ (web response)
+ (sxml simple)
+ (sxml xpath)
+ (sxml transform)
+ (ice-9 regex)
+ )
+
+
+
+(define transformer
+  `((rss:item
+     . ,(lambda (key . children)
+          (define tag (cons key children))
+          (call-with-values (lambda () (apply values ((sxpath '(rss:title *text*)) tag)))
+            (case-lambda (() tag)
+                         ((title . _)
+                          (if (string-match "^\\[\\$\\]" title)
+                              '() tag))))))))
+
+(define (parse-rss port)
+  (xml->sxml port
+             #: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/"))) )
+
+(define (filter-tree transformers tree)
+  (pre-post-order
+   tree
+   `(,@transformer
+     (*text* . ,(lambda (_ x . xs) x))
+     (*default* . ,(lambda (item  . children)
+                     (cons item children))))) )
+
+(define (main args)
+
+  (define response
+    (http-get "https://lwn.net/headlines/Features"
+              #:streaming? #t))
+
+  (unless (= 200 (response-code response))
+    (format (current-error-port) "HTTP error ~a"
+            (response-code response))
+    (exit 1))
+
+  (with-output-to-file "lwn-unlocked-features.xml"
+    (lambda ()
+      (sxml->xml
+       (filter-tree
+        transformer
+        (parse-rss (response-body-port response)))))))