basis/syndication/syndication.factor

   1 ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
   2 ! Portions copyright (C) 2008 Slava Pestov.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: xml.utilities kernel assocs xml.generator math.order
   5     strings sequences xml.data xml.writer
   6     io.streams.string combinators xml xml.entities io.files io
   7     http.client namespaces make xml.generator hashtables
   8     calendar.format accessors continuations urls present ;
   9 IN: syndication
  10
  11 : any-tag-named ( tag names -- tag-inside )
  12     f -rot [ tag-named nip dup ] with find 2drop ;
  13
  14 TUPLE: feed title url entries ;
  15
  16 : <feed> ( -- feed ) feed new ;
  17
  18 TUPLE: entry title url description date ;
  19
  20 : set-entries ( feed entries -- feed )
  21     [ dup url>> ] dip
  22     [ [ derive-url ] change-url ] with map
  23     >>entries ;
  24
  25 : <entry> ( -- entry ) entry new ;
  26
  27 : try-parsing-timestamp ( string -- timestamp )
  28     [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
  29
  30 : rss1.0-entry ( tag -- entry )
  31     entry new
  32     swap {
  33         [ "title" tag-named children>string >>title ]
  34         [ "link" tag-named children>string >url >>url ]
  35         [ "description" tag-named children>string >>description ]
  36         [
  37             f "date" "http://purl.org/dc/elements/1.1/" <name>
  38             tag-named dup [ children>string try-parsing-timestamp ] when
  39             >>date
  40         ]
  41     } cleave ;
  42
  43 : rss1.0 ( xml -- feed )
  44     feed new
  45     swap [
  46         "channel" tag-named
  47         [ "title" tag-named children>string >>title ]
  48         [ "link" tag-named children>string >url >>url ] bi
  49     ] [ "item" tags-named [ rss1.0-entry ] map set-entries ] bi ;
  50
  51 : rss2.0-entry ( tag -- entry )
  52     entry new
  53     swap {
  54         [ "title" tag-named children>string >>title ]
  55         [ { "link" "guid" } any-tag-named children>string >url >>url ]
  56         [ { "description" "encoded" } any-tag-named children>string >>description ]
  57         [
  58             { "date" "pubDate" } any-tag-named
  59             children>string try-parsing-timestamp >>date
  60         ]
  61     } cleave ;
  62
  63 : rss2.0 ( xml -- feed )
  64     feed new
  65     swap
  66     "channel" tag-named
  67     [ "title" tag-named children>string >>title ]
  68     [ "link" tag-named children>string >url >>url ]
  69     [ "item" tags-named [ rss2.0-entry ] map set-entries ]
  70     tri ;
  71
  72 : atom-entry-link ( tag -- url/f )
  73     "link" tags-named [ "rel" swap at "alternate" = ] find nip
  74     dup [ "href" swap at >url ] when ;
  75
  76 : atom1.0-entry ( tag -- entry )
  77     entry new
  78     swap {
  79         [ "title" tag-named children>string >>title ]
  80         [ atom-entry-link >>url ]
  81         [
  82             { "content" "summary" } any-tag-named
  83             dup children>> [ string? not ] contains?
  84             [ children>> [ write-xml-chunk ] with-string-writer ]
  85             [ children>string ] if >>description
  86         ]
  87         [
  88             { "published" "updated" "issued" "modified" }
  89             any-tag-named children>string try-parsing-timestamp
  90             >>date
  91         ]
  92     } cleave ;
  93
  94 : atom1.0 ( xml -- feed )
  95     feed new
  96     swap
  97     [ "title" tag-named children>string >>title ]
  98     [ "link" tag-named "href" swap at >url >>url ]
  99     [ "entry" tags-named [ atom1.0-entry ] map set-entries ]
 100     tri ;
 101
 102 : xml>feed ( xml -- feed )
 103     dup main>> {
 104         { "RDF" [ rss1.0 ] }
 105         { "rss" [ rss2.0 ] }
 106         { "feed" [ atom1.0 ] }
 107     } case ;
 108
 109 : string>feed ( string -- feed )
 110     [ string>xml xml>feed ] with-html-entities ;
 111
 112 : download-feed ( url -- feed )
 113     #! Retrieve an news syndication file, return as a feed tuple.
 114     http-get nip string>feed ;
 115
 116 ! Atom generation
 117 : simple-tag, ( content name -- )
 118     [ , ] tag, ;
 119
 120 : simple-tag*, ( content name attrs -- )
 121     [ , ] tag*, ;
 122
 123 : entry, ( entry -- )
 124     "entry" [
 125         {
 126             [ title>> "title" { { "type" "html" } } simple-tag*, ]
 127             [ url>> present "href" associate "link" swap contained*, ]
 128             [ date>> timestamp>rfc3339 "published" simple-tag, ]
 129             [ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ]
 130         } cleave
 131     ] tag, ;
 132
 133 : feed>xml ( feed -- xml )
 134     "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
 135         [ title>> "title" simple-tag, ]
 136         [ url>> present "href" associate "link" swap contained*, ]
 137         [ entries>> [ entry, ] each ]
 138         tri
 139     ] make-xml* ;