git.fiddlerwoaroof.com
Raw Blame History
(defpackage :alimenta.feed-archive.encoders
  (:use :cl :alexandria :serapeum :fw.lu :alimenta.feed-archive.tools)
  (:shadowing-import-from :alimenta.feed-archive.tools :->)
  (:export :skip-item :the-condition :the-feed :feed-error))

(in-package :alimenta.feed-archive.encoders)

(defun fix-path (path)
  ;; Work around some issue with pathnames
  (setf path (merge-pathnames path (make-pathname :type :unspecific))))

(defun skip-item ()
  (when-let ((restart (find-restart 'skip-item)))
    (invoke-restart restart)))

(define-condition feed-error (error)
  ((%feed :reader the-feed :initarg :feed :initform (error "We need a feed"))
   (%condition :reader the-condition :initarg :condition :initform (error "feed-error must wrap a condition"))))

(defun wrap-condition (condition feed)
  (error 'feed-error
	 :feed feed
	 :condition condition))

(defun %encode-feed-as-json (feed item-storage-info root-dir &optional stream)
  (with-accessors ((description alimenta:description)
		   (feed-link alimenta:feed-link)
		   (items alimenta:items)
		   (link alimenta:link)
		   (source-type alimenta:source-type)
		   (title alimenta:title)) feed)
  (yason:with-output (stream :indent t)
    (yason:with-object ()
      (yason:encode-object-element "metadata" feed)
      (yason:with-object-element ("items")
	(yason:with-array ()
	  (dolist (item item-storage-info)
            
	    (with-simple-restart (skip-item "Skip item ~s" (car item))
              ;; (format t "~&I Store Info: ~a~%~4t~a~%" (uiop:unix-namestring (cadr item)) root-dir)
	      (%encode-item root-dir item)
	      #+null
              (yason:encode-array-element (uiop:unix-namestring (uiop:enough-pathname root-dir (cadr item))))
	      )))))))

(defmethod store ((items sequence) (directory pathname))
  (map 'list (lambda (item) (store item directory))
       (stable-sort
	(sort (remove-if #'older-than-a-week items :key #'alimenta:date)
	      #'string-lessp
	      :key #'alimenta:title)
	#'local-time:timestamp>
	:key #'alimenta:date)))

(defun sort-and-filter-items (feed)
  (setf (alimenta:items feed)
	(stable-sort
	 (sort (remove-if #'older-than-a-week (alimenta:items feed)
			  :key #'alimenta:date)
	       #'string-lessp
	       :key #'alimenta:title)
	 #'local-time:timestamp>
	 :key #'alimenta:date)))

(defmethod store ((feed alimenta:feed) (directory pathname))
  (flet ((get-feed-store-name (feed directory)
	   (merge-pathnames (get-id feed)
			    directory)))

    (with-accessors ((description alimenta:description)
		     (feed-link alimenta:feed-link)
		     (items alimenta:items)
		     (link alimenta:link)
		     (source-type alimenta:source-type)
		     (title alimenta:title)) feed
      ; We wrap all errors with our own condition
      (handler-bind ((error (lambda (c) (error 'feed-error :feed feed :condition c))))
	(prog1-let ((feed-title title)
		    (feed-store (get-feed-store-name feed directory)))
	  (ensure-directories-exist feed-store)
	  (with-open-file (index (merge-pathnames "index.json" feed-store) :direction :output)
	    (%encode-feed-as-json feed
				  (store items feed-store)
				  feed-store
				  index)))))))

(defmethod store ((feed alimenta:feed) (stream stream))
  (handler-bind ((error (lambda (c)
			  (typecase c
			    (feed-error c)
			    (t (wrap-condition c feed))))))
    (yason:with-output (stream :indent t)
      (yason:with-object ()
	(yason:with-object-element ("metadata")
	  (yason:encode-object feed))
	(yason:with-object-element ("items")
	  (yason:with-array ()
	    (for:for ((item over feed))
	      (store item stream))))))))

(defun %encode-item (root-dir item)
  (destructuring-bind (title path) item
    (format t "~&Encoding ~a~%" title)
    (restart-once (fix-pathname () (fix-path path))
      (let ((pathname (uiop:enough-pathname path root-dir)))
	(yason:with-object ()
	  (yason:encode-object-element "title" title)
	  (yason:encode-object-element "path" pathname))))))

(defmethod store ((item alimenta:item) (directory pathname))
  (flet ((get-item-store-name (item directory)
	   (let ((id (get-id item)))
	     (merge-pathnames (make-pathname :name id :version nil :type "json") directory))))

    (prog1-let ((item-title (alimenta:title item))
		(fn (get-item-store-name item directory)))
      (with-open-file (item-f fn :direction :output)
	(yason:encode item item-f)))))

(defmethod store ((item alimenta:item) (stream stream))
  (yason:with-output (stream :indent t)
    (yason:encode-object item)))