main.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          main.lisp
   6 ;;;; Purpose:       Main RSS functions
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Sep 2003
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;; *************************************************************************
  12
  13 (in-package #:rss)
  14
  15 (defclass rss-channel ()
  16   ((title :reader title)
  17    (link :reader link)
  18    (description :reader description :initform nil)
  19    (language :reader language :initform nil)
  20    (image :reader image :initform nil)
  21    (pub-date :reader pub-date :initform nil)
  22    (last-build-date :reader last-build-date :initform nil)
  23
  24    (items :accessor items :initform nil)))
  25
  26 (defclass rss-item ()
  27   ((title :reader title)
  28    (link :reader link)
  29    (description :reader description :initform nil)
  30    (pub-date :reader pub-date :initform nil)))
  31
  32 (defclass rss-image ()
  33   ((url :reader url)
  34    (title :reader title)
  35    (link :reader link)
  36    (width :reader width :initform nil)
  37    (height :reader height :initform nil)
  38    (description :reader description :initform nil)))
  39
  40 (defvar *sites*
  41     '("http://www.cliki.net/recent-changes.rdf"))
  42
  43 (defun show-sites (&optional (sites *sites*))
  44   (dolist (site (mklist sites))
  45     (awhen (rss-site site)
  46            (display-site it))))
  47
  48 (defun display-site (site &key (stream *standard-output*))
  49   (format stream "Site: ~A~%" (title site))
  50   (dolist (item (items site))
  51     (format stream "  ~A~%" (title item))))
  52
  53 (defun rss-site (uri)
  54   (multiple-value-bind (body response headers true-uri)
  55       (net.aserve.client:do-http-request uri)
  56     (declare (ignore true-uri headers))
  57     (when (eql 200 response)
  58       (with-input-from-string (strm body)
  59         (parse-rss-stream strm)))))
  60
  61 (defun parse-rss-file (file)
  62   (with-open-file (stream file :direction :input)
  63     (parse-rss-stream stream)))
  64
  65 (defun is-rss-version-supported (version-string)
  66   (and (member version-string '("0.91" "0.92" "2.0") :test #'string=) t))
  67
  68 (define-condition rss-parse-error (error)
  69   ((msg :initarg :msg :reader msg))
  70   (:documentation "Thrown when PARSE-RSS-STREAM encounters invalid RSS data.")
  71   (:report
  72    (lambda (condition stream)
  73      (format stream "Parse error reading RSS~@[. ~A~]" (msg condition)))))
  74
  75 (define-condition rss-version-unsupported (rss-parse-error)
  76   ((version :initarg :version :reader version))
  77   (:documentation
  78    "Thrown when PARSE-RSS-STREAM encounters RSS of a version it doesn't
  79 recognise.")
  80   (:report
  81    (lambda (condition stream)
  82      (format stream "Unexpected RSS version: ~S" (version condition)))))
  83
  84 (defmacro string=-case (keyform (&rest cases) &optional &body otherwise)
  85   "A version of CASE that tests using string=."
  86   (let ((key (gensym)) (expected))
  87     `(let ((,key ,keyform))
  88        (cond
  89          ,@(mapcar
  90             (lambda (form)
  91               (destructuring-bind (string &body body) form
  92                 (unless (stringp string)
  93                   (error "Can only deal with strings as keys."))
  94                 (push string expected)
  95                 `((string= ,string ,key) ,@body)))
  96             cases)
  97          (t
  98           ,@otherwise)))))
  99
 100 (defun setf-unique-slot (object name value)
 101   "Set the slot with the given NAME in OBJECT to VALUE, throwing an error if it
 102 was already set."
 103   (when (and (slot-boundp object name) (slot-value object name))
 104     (error 'rss-parse-error
 105            :msg (format nil "<~A> should only be specified once in the node."
 106                         name)))
 107   (setf (slot-value object name) value))
 108
 109 (defun setf-unique-string (object name node)
 110   "Set the slot with the given NAME in OBJECT to the string contents of NODE,
 111 throwing an error if it was already set, or if they aren't a string. Used for
 112 elements like <title> and <link>, which shouldn't crop up twice."
 113   (let ((string (car (xmls:xmlrep-children node))))
 114     (unless (stringp string)
 115       (error 'rss-parse-error
 116              :msg (format nil "Got ~A when expecting string for contents of <~A>"
 117                           string name)))
 118     (setf-unique-slot object name string)))
 119
 120 (defun ensure-string-slots-filled (object required-slots strict?)
 121   "For each slot in REQUIRED-SLOTS, if it is unbound in OBJECT, set it to the
 122 empty string if STRICT? is NIL, or throw an error if true."
 123   (dolist (slot required-slots)
 124     (unless (and (slot-boundp object slot) (slot-value object slot))
 125       (if strict?
 126           (error 'rss-parse-error
 127                  :msg (format nil "Required field ~A not set for object." slot))
 128           (setf (slot-value object slot) "")))
 129     (when (and strict? (not (stringp (slot-value object slot))))
 130       (error 'rss-parse-error
 131              :msg (format nil "Slot ~A is set to ~A, which is not a string."
 132                           slot (slot-value object slot)))))
 133   (values))
 134
 135 (defun parse-type (class child-parser node strict? required-string-slots)
 136   (let ((object (make-instance class)))
 137     (map nil
 138          (lambda (subnode) (funcall child-parser subnode object strict?))
 139          (xmls:xmlrep-children node))
 140     (ensure-string-slots-filled object required-string-slots strict?)
 141     object))
 142
 143 (eval-when (:compile-toplevel :load-toplevel :execute)
 144   (defun symbol-to-name (sym)
 145     "Convert symbols in the form SOME-SYM to RSS-style camelCase (a lopsided
 146 camel, it seems)."
 147     (let ((parts (split-alphanumeric-string (symbol-name sym))))
 148       (format nil "~A~{~A~}"
 149               (string-downcase (first parts))
 150               (mapcar #'string-capitalize (cdr parts))))))
 151
 152 (defmacro def-child-parser (name (&rest unique-strings)
 153                             &rest complicated-forms)
 154   "Define a parser that sets UNIQUE-STRINGS in the obvious
 155 way. COMPLICATED-FORMS should be lists (KEY &body BODY) where KEY is a string
 156 and BODY is performed with ITEM set to the item we're modifying and NODE set to
 157 the XML node we just got."
 158   `(defun ,name (node object strict?)
 159      (declare (ignorable strict?))
 160      (string=-case (xmls:xmlrep-tag node)
 161          (,@(mapcar
 162              (lambda (sym) `(,(symbol-to-name sym)
 163                               (setf-unique-string object ',sym node)))
 164              unique-strings)
 165           ,@complicated-forms))))
 166
 167 (def-child-parser parse-item-child (title link description pub-date))
 168 (defun parse-item (node strict?)
 169   (parse-type 'rss-item 'parse-item-child node strict? '(title link)))
 170
 171 (def-child-parser parse-image-child (url title link width height description))
 172 (defun parse-image (node strict?)
 173   (parse-type 'rss-image 'parse-image-child node strict? '(url title link)))
 174
 175 (def-child-parser parse-channel-child
 176     (title link description language pub-date last-build-date)
 177   ("item" (push (parse-item node strict?) (items object)))
 178   ("image" (setf-unique-slot object 'image (parse-image node strict?))))
 179
 180 (defun parse-rss-stream (str &key err strict?)
 181   "Parse RSS data from STR, which can be either a stream or a string. If ERR,
 182 then throw an error when something goes wrong, otherwise just return NIL. If
 183 STRICT?, check more carefully for whether the document fails to follow the RSS
 184 2.0 specification (which incorporates 0.9x)"
 185   (handler-case
 186       (let* ((*package* (find-package 'kmrcl))
 187              (tree (xmls:parse str :compress-whitespace t))
 188              (children (xmls:xmlrep-children tree))
 189              (version (xmls:xmlrep-attrib-value "version" tree nil)))
 190
 191         (unless (string= "rss" (xmls:xmlrep-tag tree))
 192           (error 'rss-parse-error :msg "Data doesn't claim to be RSS."))
 193         (unless (is-rss-version-supported version)
 194           (error 'rss-version-unsupported :version version))
 195         (unless (and (= 1 (length children))
 196                      (string= "channel" (xmls:xmlrep-tag (first children))))
 197           (error 'rss-parse-error
 198                  :msg "<rss> should have one child, a <channel>."))
 199
 200         (let ((channel (first children))
 201               (rss (make-instance 'rss-channel)))
 202
 203           (map nil (lambda (child) (parse-channel-child child rss strict?))
 204                (xmls:xmlrep-children channel))
 205
 206           (ensure-string-slots-filled
 207            rss
 208            `(title link description
 209                    ,@(when (string= version "0.91") '(language)))
 210            strict?)
 211
 212           (unless (or (not strict?) (string= version "2.0") (image rss))
 213             (error 'rss-parse-error
 214                    :msg "<rss> should have <image> specified for version <2.0"))
 215
 216           (setf (items rss) (nreverse (items rss)))
 217           rss))
 218
 219     (rss-parse-error (e)
 220       (when err (error e))
 221       nil)))