@@ -3,19 +3,22 @@

   :author "Fiddlerwoaroof <fiddlerwoaroof@howit.is>"

   :license "MIT"

   :depends-on (#:alexandria

-	       #:alimenta

-	       #:fwoar.lisputils

-	       #:ironclad

-	       #:local-time

-	       #:serapeum

-	       #:ubiquitous

-	       #:uiop

-	       #:yason)

+               #:alimenta

+               #:fwoar.lisputils

+               #:ironclad

+               #:local-time

+               #:serapeum

+               #:stream-provider

+               #:trivia

+               #:ubiquitous

+               #:uiop

+               #:vector-update-stream

+               #:yason)

   :serial t

   :components ((:file "package")

-	       (:file "tools")

-	       (:file "yason-encoders")

-	       (:file "encoders")

-	       (:file "feed-index-utils")

-	       (:file "feed-archive")))

+               (:file "tools")

+               (:file "yason-encoders")

+               (:file "encoders")

+               (:file "feed-index-utils")

+               (:file "feed-archive")))

@@ -285,9 +285,9 @@ pre {

     padding: 1em;

 }

-.code .code, code code, pre pre,

 .code pre, code .code, pre code,

-.code code, code pre, pre .code,

+.code .code, code code, pre pre,

+.code code, code pre, pre .code

 {

     background: transparent;

     padding: 0;

@@ -14,98 +14,163 @@

 (defun wrap-condition (condition feed)

   (error 'feed-error

-	 :feed feed

-	 :condition condition))

+         :feed feed

+         :condition condition))

 (defmacro unwrap-feed-errors (() &body body)

   `(handler-bind ((feed-error (op (error (the-condition _)))))

      ,@body))

+(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))))))

+

 (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)

+                   (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))

+        (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

+              (%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 (op (store _ directory))

+(defmethod store ((items sequence) storage)

+  (when (next-method-p)

+    (format t "calling next...~%")

+    (call-next-method))

+  (map 'list (op (store _ storage))

        (stable-sort (sort items #'string-lessp

-			  :key #'alimenta:title)

-		    #'local-time:timestamp>

-		    :key #'alimenta:date)))

+                          :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)))

+           (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

+                     (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))))

-	(values (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)))

-		feed-link)))))

+        (values (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 (copy-seq items) feed-store)

+                                          feed-store

+                                          index)))

+                feed-link)))))

 (defmethod store ((feed alimenta:feed) (stream stream))

   (handler-bind ((error (lambda (c)

-			  (typecase c

-			    (feed-error c)

-			    (t (wrap-condition c feed))))))

+                          (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))))))

+        (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))))))

+    (list (alimenta:title feed)

+          stream)))

 (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))))

+           (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)))

+                (fn (get-item-store-name item directory)))

       (with-open-file (item-f fn :direction :output)

-	(yason:encode item item-f)))))

+        (yason:encode item item-f)))))

 (defmethod store ((item alimenta:item) (stream stream))

   (yason:with-output (stream :indent t)

-    (yason:encode-object item)))

+    (yason:encode-object item))

+  (list (alimenta:title item)

+        stream))

+

+;; The feed is always index.json

+(defmethod stream-provider:stream-key (provider (feed alimenta:feed))

+  (pathname

+   (string-join

+    (list (get-id feed)

+          "index.json")

+    "/")))

+

+(defmethod stream-provider:stream-key :around ((provider stream-provider:file-provider)

+                                               (feed alimenta:feed))

+  (prog1-bind (result (call-next-method))

+    (ensure-directories-exist (merge-pathnames result

+                                               (stream-provider:root provider)))))

+

+(defmethod stream-provider:stream-key (provider (item alimenta:item))

+  (let ((id (get-id item)))

+    (make-pathname :name id :version nil :type "json")))

+(defclass feed-stream-provider (stream-provider:file-provider)

+  ((%item-providers :accessor item-providers :initform (make-hash-table :test 'equal))))

+

+(defmethod stream-provider:get-nested-provider ((provider stream-provider:stream-provider) (streamable alimenta:feed))

+  (with (items-root (uiop:merge-pathnames* (uiop:pathname-directory-pathname (stream-provider:stream-key provider streamable))

+                                           (stream-provider:root provider)))

+    (format t "~&items-root: ~a   @#%@#$^#$&^&%$~%" items-root) (terpri)

+    (ensure-gethash items-root

+                    (item-providers provider)

+                    (make-instance 'stream-provider:file-provider :root items-root))))

+

+(defmethod store :around ((item alimenta:feed-entity) (stream-provider stream-provider:stream-provider))

+  (call-next-method)

+  (list (alimenta:title item)

+        (stream-provider:stream-key stream-provider item)))

+

+(defmethod store ((item alimenta:item) (stream-provider stream-provider:stream-provider))

+  (stream-provider:with-storage-stream (s item stream-provider)

+    (store item s)))

+

+(defmethod store ((feed alimenta:feed) (stream-provider stream-provider:stream-provider))

+  (stream-provider:with-storage-stream (s feed stream-provider)

+    (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

+      (let* ((item-provider (stream-provider:get-nested-provider stream-provider feed))

+             (item-storage-info (map 'list (op (store _ item-provider))

+                                                        items)))

+        (yason:with-output (s :indent t)

+          (yason:with-object ()

+            (yason:encode-object-element "metadata" feed)

+            (yason:with-object-element ("items")

+              (yason:with-array ()

+                (dolist (item item-storage-info)

+                  (destructuring-bind (title path) item

+                    (yason:with-object ()

+                      (yason:encode-object-elements "title" title

+                                                    "path" path))))))))))))

@@ -8,59 +8,59 @@

 (defun get-store-directory-name (timestamp)

   (flet ((make-dirname (timestamp)

-	   (-> (local-time:format-timestring nil (local-time:timestamp-minimize-part timestamp :sec)

-					     :format +dirname-format+)

-	       (merge-pathnames *feed-base*))))

+           (-> (local-time:format-timestring nil (local-time:timestamp-minimize-part timestamp :sec)

+                                             :format +dirname-format+)

+               (merge-pathnames *feed-base*))))

     (-> (prog1-let ((result (make-dirname timestamp)))

-	  (ensure-directories-exist result))

-	(car))))

+          (ensure-directories-exist result))

+        (car))))

 (defun test-feed-list ()

   (values '("http://feeds.feedburner.com/GamasutraFeatureArticles/"

-	    "https://www.codinghorror.com/blog/index.xml"

-	    "https://sancrucensis.wordpress.com/feed/")

-	  #p"/tmp/feed-archive/"))

+            "https://www.codinghorror.com/blog/index.xml"

+            "https://sancrucensis.wordpress.com/feed/")

+          #p"/tmp/feed-archive/"))

 (defun init-feeds (&key feed-list archive-root)

   (ubiquitous:restore 'alimenta.feed-archiver)

   (let ((default-root (or archive-root

-			  (merge-pathnames ".feed-archive/"

-					   (truename "~/")))))

+                          (merge-pathnames ".feed-archive/"

+                                           (truename "~/")))))

     (values (ubiquitous:defaulted-value feed-list :feeds)

-	    (ubiquitous:defaulted-value default-root :archive :root))))

+            (ubiquitous:defaulted-value default-root :archive :root))))

 (defun add-feed (feed)

   (init-feeds)

   (pushnew feed

-	   (ubiquitous:value :feeds)

-	   :test #'equalp))

+           (ubiquitous:value :feeds)

+           :test #'equalp))

 (defun safe-pull-feed (feed-url &aux (pop-times 0))

   "Handles date parsing errors in the feed: chronicity won't parse

    certain date formats, this catches the error and modifies the

    format to something chronicity can handle."

   (flet ((pop-50-tokens (c)

-	   (declare (ignore c))

-	   (when (find-restart 'alimenta:pop-token) 

-	     (if (< pop-times 50)

-		 (progn (incf pop-times)

-			(format t "~&Processing error, trying to pop a token (popped ~d times)~%"

-				pop-times)

-			(alimenta:pop-token))

-		 (continue)))))

+           (declare (ignore c))

+           (when (find-restart 'alimenta:pop-token) 

+             (if (< pop-times 50)

+                 (progn (incf pop-times)

+                        (format t "~&Processing error, trying to pop a token (popped ~d times)~%"

+                                pop-times)

+                        (alimenta:pop-token))

+                 (continue)))))

     (handler-bind ((warning #'muffle-warning)

-		   (error #'pop-50-tokens))

+                   (error #'pop-50-tokens))

       (prog1 (alimenta.pull-feed:pull-feed feed-url)

-	;; Why am I decf-ing here?

-	(decf pop-times)))))

+        ;; Why am I decf-ing here?

+        (decf pop-times)))))

 (defmacro with-progress-message ((stream before after &optional (error-msg " ERROR~%~4t~a~%")) &body body)

   (once-only (before after stream)

     `(handler-bind ((error (op (format ,stream ,error-msg _))))

        (format ,stream "~&~a . . ." ,before)

        (multiple-value-prog1 (progn

-			       ,@body)

-	 (format ,stream " ~a~%" ,after)))))

+                               ,@body)

+         (format ,stream " ~a~%" ,after)))))

 (defun skip-feed ()

   (when-let ((restart (find-restart 'skip-feed)))

@@ -72,41 +72,57 @@

 (defun pull-and-store-feeds (feeds pull-directory)

   (mapcar (op (pull-and-store-feed _ pull-directory))

-	  feeds))

+          feeds))

-(defun pull-and-store-feed (feed-url pull-directory)

+(defun log-pull (feed-puller feed-url stream)

+  (let ((before-message (concatenate 'string "Trying to pull: " feed-url)))

+    (with-progress-message (stream before-message "Success")

+      (funcall feed-puller feed-url))))

+

+(defun normalize-feed (feed-url feed)

+  (alimenta:filter-feed (coerce-feed-link feed-url feed)

+                        (complement #'older-than-a-month)

+                        :key 'alimenta:date))

+

+(defun log-serialization (feed-url stream feed path)

+  (with-progress-message (stream "Serializing XML" (format nil "done with ~a" feed-url))

+    (save-feed feed (merge-pathnames "feed.xml" path))))

+

+(defun feed-relative-pathname (path &optional (feed-base *feed-base*))

+  (uiop:enough-pathname path feed-base))

+

+(defun pull-and-store-feed (feed-url pull-directory &optional (feed-puller #'safe-pull-feed))

   (flet ((log-pull (stream)

-	   (let ((before-message (format nil "Trying to pull: ~a" feed-url)))

-	     (with-progress-message (stream before-message "Success")

-	       (prog1 (safe-pull-feed feed-url)))))

-	 (log-serialization (stream feed path)

-	   (with-progress-message (stream "Serializing XML" (format nil "done with ~a" feed-url))

-	     (save-feed feed (merge-pathnames "feed.xml" path)))))

+           (declare (inline) (dynamic-extent stream))

+           (log-pull feed-puller feed-url stream))

+         (log-serialization (stream feed path)

+           (declare (inline) (dynamic-extent stream))

+           (log-serialization feed-url stream feed path)))

     (with-simple-restart (skip-feed "Stop processing for ~a" feed-url)

       (let* ((feed (with-retry ("Pull feed again.")

-		     (alimenta:filter-feed (coerce-feed-link feed-url

-							     (log-pull t))

-					   (complement #'older-than-a-month)

-					   :key 'alimenta:date))))

-	(multiple-value-bind (result url) (store feed pull-directory)

-	  (destructuring-bind (title path) result

-	    (log-serialization t feed path)

-	    (make-feed-reference url :title title

-				 :path (uiop:enough-pathname path *feed-base*))))))))

+                     (normalize-feed feed-url (log-pull t)))))

+        (trivia:multiple-value-match (store feed pull-directory)

+          (((list title path) url)

+           (log-serialization t feed path)

+           (make-feed-reference url :title title :path (feed-relative-pathname path))))))))

 (defun feed-index (index-stream pull-time references)

   (yason:with-output (index-stream :indent t)

     (yason:encode-object

      (make-feed-index pull-time (remove-if 'null references)))))

-(defun archive-feeds ()

+(defun archive-feeds (pull-time pull-directory index-stream)

+  (let ((references (pull-and-store-feeds *feeds* pull-directory)))

+    (feed-index index-stream pull-time references)

+    references))

+

+(defun archive-feeds-nondeterm ()

   (let* ((pull-time (local-time:now))

 	 (pull-directory (get-store-directory-name pull-time)) 

-	 (references (pull-and-store-feeds *feeds* pull-directory))

 	 (index-path (merge-pathnames "index.json" pull-directory)))

     (with-open-file (index index-path :direction :output)

-      (feed-index index pull-time references))

+      (archive-feeds pull-time pull-directory index))

     (format t "~&!! pull-directory ~a~%" (uiop:enough-pathname pull-directory *feed-base*))))

 ;; This is an ungodly mess, we need to avoid funneling everything through fix-pathname-or-skip

@@ -144,4 +160,5 @@

 			  (fix-pathname-or-skip _1 :restart 'continue)))))

 	(multiple-value-bind (*feeds* *feed-base*) (funcall feed-list-initializer)

 	  (alimenta.pull-feed:with-user-agent ("Feed Archiver v0.1b")

-	    (archive-feeds)))))))

+	    (archive-feeds-nondeterm)))))))

+

@@ -1,18 +1,32 @@

-(defpackage :alimenta.feed-archive.tools

-  (:use :cl :alexandria :serapeum :fw.lu)

+(defpackage :afa-user

+  (:use cl)

+  (:export #:define-package))

+(in-package :afa-user)

+

+(defmacro define-package (name &body arguments)

+  (let ((uses (cons :use

+		    (union '(:cl :alexandria :serapeum)

+			   (cdr (assoc :use arguments))))))

+    `(progn

+       (defpackage ,name

+	 ,uses

+	 ,@(remove :use arguments :key 'car)))))

+

+(define-package :alimenta.feed-archive.tools

+  (:use :fw.lu)

   (:shadow :->)

   (:export :fix-pathname :sha256-string :get-id :older-than-a-week :-> :get-feed-store-name

 	   :store :get-item-store-name :restart-once :coerce-feed-link :with-retry

 	   :older-than-a-month))

-(defpackage :alimenta.feed-archive.encoders

-  (:use :cl :alexandria :serapeum :fw.lu :alimenta.feed-archive.tools)

+(define-package :alimenta.feed-archive.encoders

+  (:use :fw.lu :alimenta.feed-archive.tools)

   (:shadowing-import-from :alimenta.feed-archive.tools :->)

   (:export :skip-item :the-condition :the-feed :feed-error

-	   :unwrap-feed-errors))

+           :unwrap-feed-errors :feed-stream-provider))

-(defpackage :alimenta.feed-archive

-  (:use :cl :alexandria :serapeum :fw.lu :alimenta.feed-archive.tools)

+(define-package :alimenta.feed-archive

+  (:use :fw.lu :alimenta.feed-archive.tools)

   (:shadowing-import-from :alimenta.feed-archive.tools :->)

   (:export #:init-feeds #:archive-feeds #:command-line-main))

new file mode 100644

@@ -0,0 +1,68 @@

+(afa-user:define-package :stream-provider

+  (:use :fw.lu)

+  (:export

+   #:get-stream-for

+   #:stream-provider

+   #:string-provider

+   #:file-provider

+   #:stream-key

+   #:root

+   #:streams

+   #:with-storage-stream))

+(cl:in-package :stream-provider)

+

+(defclass stream-provider ()

+  ())

+

+(defvar *store-root* *default-pathname-defaults*)

+

+(defgeneric stream-key (provider item)

+  (:documentation "return a key for an item: must be able to be compared with EQUAL

+

+If you override on provider, make sure to CALL-NEXT-METHOD"))

+

+(defgeneric get-stream-for (provider streamable &rest extra-args)

+  (:documentation "get a stream for a given streamable object"))

+

+(defgeneric root (provider)

+  (:documentation "get the base path for the streams"))

+

+

+(defclass string-provider (stream-provider)

+  ((%streams :reader streams :initform (make-hash-table :test 'equal))))

+

+(defmethod root ((provider string-provider))

+  #p"/")

+

+(defmethod stream-key :around (provider item)

+  (let ((key (call-next-method)))

+    (check-type key (or string pathname))

+    (uiop:enough-pathname key (root provider))))

+

+(defmethod get-stream-for ((provider string-provider) streamable &rest extra-args)

+  (declare (ignore extra-args))

+  (with-accessors* (streams) provider

+    (vector-update-stream:make-update-stream 

+     (setf (gethash (stream-key provider streamable) streams)

+           (make-array 10 :adjustable t :fill-pointer 0)))))

+

+(defclass file-provider (stream-provider)

+  ((%root :initarg :root :initform (error "need a root for a file-provider") :reader root)

+   (%if-exists :initarg :if-exists :initform :supersede :reader if-exists)))

+

+(defmethod get-stream-for ((provider file-provider) streamable &rest extra-args)

+  (declare (ignore extra-args))

+  (with-accessors* (if-exists root) provider

+    (let ((stream-key (merge-pathnames (stream-key provider streamable)

+                                       root)))

+      (when (eql if-exists :if-exists)

+        (ensure-directories-exist stream-key))

+      (open stream-key :direction :output :if-exists if-exists

+            :element-type 'octet))))

+

+(defmacro with-storage-stream ((stream-sym object provider &rest extra-args) &body body)

+  (once-only (object)

+    `(let ((,stream-sym (flexi-streams:make-flexi-stream (get-stream-for ,provider ,object ,@extra-args)

+                                                         :external-format :utf-8)))

+       (unwind-protect (progn ,@body)

+         (close ,stream-sym)))))