;;;; alimenta.lisp -*- tab-width: 8; -*-
;; (declaim (optimize (speed 0) (safety 3) (debug 3)))
(in-package #:alimenta)
(defclass feed-entity ()
((title :initarg :title :initform nil :accessor title)
(link :initarg :link :initform nil :accessor link)
(doc :initarg :doc :initform nil :accessor doc)))
(defgeneric belongs-to (feed-entity)
(:documentation "Returns the person responsible for this feed item"))
(define-condition feed-type-unsupported (error)
((%type :initarg :type :reader feed-type)
(%feed-link :initarg :feed-link :reader feed-link)))
(defgeneric -to-feed (doc type &key feed-link)
(:documentation "Given an xml-document, return a feed object")
(:method (doc type &key feed-link)
(error 'feed-type-unsupported :type type :feed-link feed-link)))
(defgeneric render (object renderer)
(:documentation "Given a lisp object representing a feed, return it rendered
to the specified format"))
(defgeneric generate-xml (feed feed-type &key partial)
(:documentation "Given a lisp object representing a feed, return an xml
document"))
(defgeneric content-el (entity)
(:documentation "Return the element that contains the item's content"))
(defclass item (feed-entity)
((author :initarg :author :initform nil :accessor author)
(content :initarg :content :initform nil :accessor content)
(description :initarg :description :accessor description)
(date :initarg :date :initform nil :accessor date)
(id :initarg :id :initform nil :accessor id)
(links :initform (make-hash-table :test #'equalp) :accessor links)))
(collection-class:define-collection (feed item) (feed-entity)
((description :initarg :description :initform nil :accessor description)
(feed-link :initarg :feed-link :initform nil :accessor feed-link)
(source-type :initarg :source-type :initform nil :accessor source-type)))
(defmethod render ((feed feed) renderer)
(let ((doc (alimenta.render:render-feed renderer feed)))
(for:for ((item over feed))
(setf doc
(alimenta.render:add-rendered-item renderer
doc
(alimenta.render:render-item renderer item feed))))
doc))
(defmethod (setf feed-link) ((value string) (feed feed))
(setf (slot-value feed 'feed-link)
(puri:parse-uri value)))
(defmethod initialize-instance :after ((feed feed) &key feed-link)
(when feed-link
(setf (feed-link feed) (puri:parse-uri feed-link))))
(defmethod belongs-to ((item item))
(author item))
(defclass complex-value () ())
(defgeneric primary-value (self)
(:documentation "Primarily for COMPLEX-VALUES: this should take one and
return a useful primary value"))
(defgeneric push-item (feed item)
(:documentation "Adds an item to the feed"))
(defgeneric make-item (xml-dom doc-type)
(:documentation "Given an xml document, return an item"))
(defgeneric parse-feed (feed)
(:documentation "Parse a feed into a lisp object"))
(defgeneric get-items (xml feed-type)
(:documentation "Given an xml document, extract its items"))
(defmethod primary-value ((self t))
self)
(define-condition duplicate-link-type (error)
((old :reader duplicate-link-type-old :initarg :old)
(new :reader duplicate-link-type-new :initarg :new))
(:report (lambda (condition stream)
(format stream "Item already has link ~s" (duplicate-link-type-old condition)))))
(defmethod generate-xml :around ((feed feed) feed-type &rest r)
(declare (ignore r))
(let ((result (call-next-method feed feed-type)))
(with-accessors ((items items)) feed
(loop for item in items
do (generate-xml item feed-type :partial result)))
result))
(defmethod -to-feed ((doc stream) doc-type &key feed-link)
(-to-feed (plump:parse doc)
doc-type
:feed-link feed-link))
(defmethod -to-feed ((doc string) doc-type &key feed-link)
(-to-feed (plump:parse doc)
doc-type
:feed-link feed-link))
(defmethod -to-feed :around ((xml-dom plump:node) doc-type &key feed-link)
"This wraps the particular methods so that _they_ don't have to implement
item fetching. NIL passed to the type activates auto-detection"
(aprog1 (call-next-method xml-dom doc-type :feed-link feed-link)
(with-slots (doc source-type) it
(setf doc xml-dom
source-type doc-type))
(setf
(items it)
(loop for item across (get-items xml-dom doc-type)
collect (make-item item doc-type)))))
(defgeneric (setf link) (value self))
(defmethod (setf link) ((value cons) (self item))
(with-slots (links) self
(destructuring-bind (type . href) value
(when (consp href)
(if (null (cdr href))
(setf href (car href))
(error 'type-error "too many arguments")))
(let ((type-keyword (make-keyword (string-upcase type))))
(when (slot-boundp self 'links)
(multiple-value-bind (old-link old-link-p) (gethash type-keyword links)
(when old-link-p
(cerror "Replace Link ~a:~a with ~a:~a" 'duplicate-link-type :old old-link :new href))))
(setf (gethash type-keyword links) href)))))
(defmethod print-object ((object feed) stream)
(print-unreadable-object (object stream :type t :identity t)
(with-slots (title link) object
(format stream "title: ~s link: ~s"
(aif title (shorten-link it) "<untitled>")
(aif link (shorten-link it) "<no link>")))))
(defmethod print-object ((object item) stream)
(print-unreadable-object (object stream :type t :identity t)
(with-slots (title link date) object
(format stream "title: ~s link: ~s date:~s"
(aif title (shorten-link it) "<untitled>")
(aif link (shorten-link it) "<no link>")
(aif date it "<no date>")))))
(defun detect-feed-type (xml-dom)
(let ((root-node-name (make-keyword (string-upcase
($ (inline xml-dom) (children)
(map #'tag-name) (node))))))
(case root-node-name
((:feed) :atom)
((:rdf :|RDF:RDF|) :rss)
(t root-node-name))))
(defgeneric get-random-item (feed)
(:method ((feed feed))
(let* ((items (copy-seq (items feed)))
(num-items (length items)))
(elt items
(random num-items)))))
(defgeneric get-latest-item (feed)
(:method ((feed feed))
(let ((items (copy-seq (items feed))))
(car (sort items
#'local-time:timestamp>
:key #'date)))))
;;(defun generate-xml (feed &key (feed-type :rss))
;; (%generate-xml feed feed-type))
(defun to-feed (doc &key type feed-link)
"Makes an instance of feed from the given document. Specialize to-feed with
an equal-specializer on type with an appropriate symbol to implement a new
sort of feed."
(unless type
(setf type (detect-feed-type doc)))
(-to-feed doc type :feed-link feed-link))
;;(defun -get-items (feed xml-dom &key type)
;; (with-accessors ((items items)) feed
;; (loop for item across (get-items xml-dom type)
;; do (push (make-item xml-dom type) items)
;; finally (return items))))
(defun make-feed (&key title link items feed-link description)
(make-instance 'feed
:description description
:feed-link feed-link
:items items
:link link
:title title))
(let ((n 0))
(defun next-id ()
(incf n)))
(defun add-item-to-feed (feed &key title (next-id #'next-id) date link content)
(alet (make-instance 'item :title title :date date :link link :content content)
(with-slots (id) it
(setf id (funcall next-id it)))
(push-item feed it)
(values feed it)))
(defun filter-feed (feed function &key key)
(setf (items feed)
(remove-if-not function (items feed)
:key key))
feed)
(defgeneric transform (item transform)
(:documentation "transform a feed entity by TRANSFORM: the
function will be called with either a feed or a item as an arguments
and, if called upon a feed, it'll automatically be mapped across the
feed's items after being called on the feed. We do not use the results
of this mapping directly, however any modifications to an item mutate
the original.")
(:method :around (item transform)
(call-next-method)
item)
(:method ((feed feed-entity) transform)
(funcall transform feed))
(:method :after ((feed feed) transform)
(map nil (lambda (it)
(transform it transform))
(items feed))))
(defun transform-content (item function)
(setf (content item)
(funcall function
(content item))))
(defun shorten-link (link)
(let ((link (cl-ppcre:regex-replace "^https?:" link "")))
(subseq link 0 (min 30 (length link)))))
(defmethod push-item ((feed feed) (item item))
(push item
(items feed)))
(deftest push-item ()
(let ((feed (make-instance 'feed))
(item (make-instance 'item)))
(with-accessors ((items items)) feed
;;(should signal error (push-item feed 2))
(should be eql item
(progn
(push-item feed item)
(car items))))))
;; vim: set foldmethod=marker: