Sfoglia il codice sorgente

Generalize DISCOVER for all content-types.

Brit Butler 12 anni fa
parent
commit
58fe27aa54
3 ha cambiato i file con 13 aggiunte e 15 eliminazioni
  1. 1 1
      src/coleslaw.lisp
  2. 12 5
      src/content.lisp
  3. 0 9
      src/posts.lisp

+ 1 - 1
src/coleslaw.lisp

54
                        (merge-pathnames "static" (repo *config*))))
54
                        (merge-pathnames "static" (repo *config*))))
55
       (when (probe-file dir)
55
       (when (probe-file dir)
56
         (run-program "cp -R ~a ." dir)))
56
         (run-program "cp -R ~a ." dir)))
57
-    (do-ctypes (publish ctype))
57
+    (do-ctypes (publish (make-keyword ctype)))
58
     (render-indices)
58
     (render-indices)
59
     (render-feeds (feeds *config*))))
59
     (render-feeds (feeds *config*))))
60
 
60
 

+ 12 - 5
src/content.lisp

34
   "Test if OBJ was written in MONTH."
34
   "Test if OBJ was written in MONTH."
35
   (search month (content-date obj)))
35
   (search month (content-date obj)))
36
 
36
 
37
-(defgeneric discover (content-type)
38
-  (:documentation "Load all content of the given CONTENT-TYPE from disk."))
39
-
40
 (defgeneric publish (content-type)
37
 (defgeneric publish (content-type)
41
   (:documentation "Write pages to disk for all content of the given CONTENT-TYPE."))
38
   (:documentation "Write pages to disk for all content of the given CONTENT-TYPE."))
42
 
39
 
74
   (dolist (obj (find-all content-type))
71
   (dolist (obj (find-all content-type))
75
     (remhash (content-slug obj) *content*)))
72
     (remhash (content-slug obj) *content*)))
76
 
73
 
74
+(defun discover (content-type)
75
+  "Load all content of the given CONTENT-TYPE from disk."
76
+  (purge-all content-type)
77
+  (let ((file-type (string-downcase (princ-to-string content-type))))
78
+    (do-files (file (repo *config*) file-type)
79
+      (let ((obj (construct content-type (read-content file))))
80
+        (if (gethash (content-slug obj) *content*)
81
+            (error "There is already existing content with the slug ~a."
82
+                   (content-slug obj))
83
+            (setf (gethash (content-slug obj) *content*) obj))))))
84
+
77
 (defmacro do-ctypes (&body body)
85
 (defmacro do-ctypes (&body body)
78
   "Iterate over the subclasses of CONTENT performing BODY with ctype lexically
86
   "Iterate over the subclasses of CONTENT performing BODY with ctype lexically
79
 bound to the current subclass."
87
 bound to the current subclass."
80
   (alexandria:with-gensyms (ctypes)
88
   (alexandria:with-gensyms (ctypes)
81
     `(let ((,ctypes (closer-mop:class-direct-subclasses (find-class 'content))))
89
     `(let ((,ctypes (closer-mop:class-direct-subclasses (find-class 'content))))
82
-       (loop for ctype in (mapcar (compose 'make-keyword 'class-name) ,ctypes)
83
-          do ,@body))))
90
+       (loop for ctype in (mapcar #'class-name ,ctypes) do ,@body))))
84
 
91
 
85
 (defun load-content ()
92
 (defun load-content ()
86
   "Load all content stored in the blog's repo."
93
   "Load all content stored in the blog's repo."

+ 0 - 9
src/posts.lisp

21
             format (make-keyword (string-upcase format))
21
             format (make-keyword (string-upcase format))
22
             text (render-content text format))))
22
             text (render-content text format))))
23
 
23
 
24
-(defmethod discover ((content-type (eql :post)))
25
-  (purge-all 'post)
26
-  (do-files (file (repo *config*) "post")
27
-    (let ((post (construct 'post (read-content file))))
28
-      (if (gethash (content-slug post) *content*)
29
-          (error "There is already an existing post with the slug ~a."
30
-                 (content-slug post))
31
-          (setf (gethash (content-slug post) *content*) post)))))
32
-
33
 (defmethod publish ((content-type (eql :post)))
24
 (defmethod publish ((content-type (eql :post)))
34
   (loop for (next post prev) on (append '(nil) (by-date (find-all 'post)))
25
   (loop for (next post prev) on (append '(nil) (by-date (find-all 'post)))
35
      while post do (write-page (page-path post)
26
      while post do (write-page (page-path post)