content.lisp (13252B)
1 (in-package :miniblog.content) 2 3 (let* ((this-file #.(or *compile-file-truename* *load-truename*)) 4 (src-dir (pathname-directory this-file)) 5 (templates-dir (append (butlast src-dir) '("templates")))) 6 (add-template-directory (make-pathname :directory templates-dir)) 7 (defvar *posts-template* (compile-template* "posts.dtl")) 8 (defvar *page-template* (compile-template* "page.dtl")) 9 (defvar *rss-template* (compile-template* "rss.dtl"))) 10 11 (defun render-posts (posts pages &key stream title root-uri header links 12 stylesheet year month archive-date-list 13 enable-rss twitter-card) 14 (render-template* *posts-template* stream 15 :posts posts 16 :pages pages 17 :title title 18 :root-uri root-uri 19 :header header 20 :links links 21 :stylesheet stylesheet 22 :year year 23 :month month 24 :archive-date-list archive-date-list 25 :enable-rss enable-rss 26 :twitter-card twitter-card)) 27 28 (defun render-page (page path pages &key stream title root-uri header links 29 stylesheet year month 30 archive-date-list enable-rss 31 twitter-card) 32 (render-template* *page-template* stream 33 :page page 34 :path path 35 :pages pages 36 :title title 37 :root-uri root-uri 38 :header header 39 :links links 40 :stylesheet stylesheet 41 :year year 42 :month month 43 :archive-date-list archive-date-list 44 :enable-rss enable-rss 45 :twitter-card twitter-card)) 46 47 (defun render-rss (posts &key stream title link description image-url language 48 copyright managing-editor webmaster category) 49 (render-template* *rss-template* stream 50 :posts posts 51 :title title 52 :link link 53 :description description 54 :image-url image-url 55 :language language 56 :copyright copyright 57 :managing-editor managing-editor 58 :webmaster webmaster 59 :category category 60 :build-date (miniblog.format:rfc-822-format (now)) )) 61 62 (defun make-generator (&key title root-uri header links stylesheet) 63 (lambda (posts pages &key year month archive-date-list enable-rss twitter-card) 64 (render-posts posts pages 65 :title title 66 :root-uri root-uri 67 :header header 68 :links links 69 :stylesheet stylesheet 70 :year year 71 :month month 72 :archive-date-list archive-date-list 73 :enable-rss enable-rss 74 :twitter-card twitter-card))) 75 76 (defun make-page-generator (&key title root-uri header links stylesheet) 77 (lambda (page path pages &key archive-date-list enable-rss twitter-card) 78 (render-page page path pages 79 :title title 80 :root-uri root-uri 81 :header header 82 :links links 83 :stylesheet stylesheet 84 :enable-rss enable-rss 85 :twitter-card twitter-card 86 :archive-date-list archive-date-list))) 87 88 (defun make-rss-generator (&key title link description image-url language 89 copyright managing-editor webmaster category) 90 (if (and title link description) 91 (lambda (posts) 92 (render-rss posts 93 :title title 94 :link link 95 :description description 96 :image-url image-url 97 :language language 98 :copyright copyright 99 :managing-editor managing-editor 100 :webmaster webmaster 101 :category category)) 102 (lambda (posts) 103 (declare (ignore posts))))) 104 105 (defun get-page-by-path (path pages) 106 (labels ((get-page-name (name page-list) 107 (find-if #'(lambda (page) (string= name (getf page :name))) 108 page-list))) 109 (car (last (loop for path-elem in path 110 for curr-page = pages then next-page 111 for page-list = (getf curr-page :children) 112 for next-page = (get-page-name path-elem page-list) 113 when (null next-page) return nil 114 collect next-page))))) 115 116 (defun get-page-id-by-path (path pages) 117 (getf (get-page-by-path path pages) :id)) 118 119 (defun get-path-to-page (id pages-table) 120 (reverse (loop for next-id = id then (getf page :parent) 121 until (zerop next-id) 122 for page = (gethash next-id pages-table) 123 when (null page) return nil 124 collect (getf page :name)))) 125 126 (defun year-month-of-entry (entry) 127 (if (not entry) 128 (error "Entry cannot be nil") 129 (let* ((entry-created-at (getf entry :created-at)) 130 (entry-year (timestamp-year entry-created-at)) 131 (entry-month (timestamp-month entry-created-at))) 132 (cons entry-year entry-month)))) 133 134 (defun year-month-of-latest-entry (entries) 135 (if (not entries) 136 (error "List of entries cannot be empty") 137 (year-month-of-entry (car entries)))) 138 139 (defun monthcdr (entries year month) 140 (if (not entries) 141 nil 142 (let* 143 ((year-month (year-month-of-latest-entry entries)) 144 (entry-year (car year-month)) 145 (entry-month (cdr year-month))) 146 (cond 147 ((< entry-year year) entries) 148 ((and (= entry-year year) (<= entry-month month)) entries) 149 (t (monthcdr (cdr entries) year month)))))) 150 151 (defun collect-entries-for-month (entries year month) 152 (if (not entries) 153 (cons nil entries) 154 (let* ((year-month (year-month-of-latest-entry entries)) 155 (entry-year (car year-month)) 156 (entry-month (cdr year-month))) 157 (if (or (/= entry-year year) (/= entry-month month)) 158 (cons nil entries) 159 (let ((collected (collect-entries-for-month 160 (cdr entries) year month))) 161 (cons (cons (car entries) (car collected)) (cdr collected))))))) 162 163 (defun get-archive-date-list (entries) 164 (labels 165 ((get-year-month-pair-for-entry (entry) 166 (let* ((created-at (getf entry :created-at)) 167 (year (timestamp-year created-at)) 168 (month (timestamp-month created-at))) 169 (cons year month))) 170 (year-month-pairs-equal-p (a b) 171 (and (= (car a) (car b)) (= (cdr a) (cdr b))))) 172 (remove-duplicates 173 (mapcar #'get-year-month-pair-for-entry entries) 174 :test #'year-month-pairs-equal-p))) 175 176 (defun gen-all-pages (pages &key prefix all-pages archive-date-list generator enable-rss twitter-card) 177 "Generate all pages in the tree rooted at PAGES. PREFIX may be supplied if this is a subtree, in which case ALL-PAGES should also be supplied so that the page nav can render correctly." 178 (labels ((with-paths (parent-path entries) 179 (mapcar #'(lambda (entry) 180 (cons entry 181 (append parent-path (cons (getf entry :name) nil)))) 182 entries)) 183 (gen-pages-recur (generated queue) 184 (if (= 0 (length queue)) 185 generated 186 (let* ((next-page (caar queue)) 187 (path (cdar queue)) 188 (next-page-content (gen-page next-page 189 path 190 (or all-pages pages) 191 :generator generator 192 :archive-date-list archive-date-list 193 :twitter-card twitter-card 194 :enable-rss enable-rss)) 195 (next-page-entry (list :page path next-page-content)) 196 (queue-rest (cdr queue)) 197 (queue-new (with-paths path (getf next-page :children)))) 198 (gen-pages-recur (append generated (cons next-page-entry nil)) 199 (append queue-rest queue-new)))))) 200 (gen-pages-recur nil (with-paths prefix (getf pages :children))))) 201 202 (defun gen-all (entries pages &key generator page-generator rss-generator twitter-card) 203 "Generate a list of all monthly pages and hierarchical pages as well as the index and RSS feed" 204 (labels 205 ((gen-all-years (entries pages archive-date-list generator enable-rss) 206 (let ((rest-entries (copy-list entries)) 207 (content '())) 208 (loop for year-month in archive-date-list do 209 (let ((month-content 210 (gen-month rest-entries 211 (car year-month) (cdr year-month) 212 pages 213 :twitter-card twitter-card 214 :enable-rss enable-rss 215 :archive-date-list archive-date-list 216 :generator generator))) 217 (setf rest-entries (cdr month-content)) 218 (setf content (cons (car month-content) content)))) 219 content))) 220 (let ((archive-date-list (get-archive-date-list entries)) 221 (rss-content (gen-rss-feed entries 222 :generator rss-generator))) 223 (append (list 224 (list :rss nil rss-content) 225 (list :index nil (gen-index entries pages 226 :twitter-card twitter-card 227 :enable-rss rss-content 228 :archive-date-list archive-date-list 229 :generator generator))) 230 (gen-all-pages pages 231 :archive-date-list archive-date-list 232 :generator page-generator 233 :twitter-card twitter-card 234 :enable-rss rss-content) 235 (gen-all-years entries pages 236 archive-date-list generator rss-content))))) 237 238 (defun top-ten (entries) 239 (if (>= (length entries) 10) 240 (subseq entries 0 10) 241 entries)) 242 243 (defun gen-rss-feed (entries &key generator) 244 "Generate the RSS feed content with the same posts as the index page" 245 (let ((index-entries (top-ten entries))) 246 (funcall (or generator (make-rss-generator)) 247 index-entries))) 248 249 (defun gen-index (entries pages &key generator archive-date-list enable-rss twitter-card) 250 "Generate the index (front page) with the latest ten posts" 251 (if (not entries) 252 (funcall (or generator (make-generator)) nil) 253 (let ((archive-date-list (or archive-date-list 254 (get-archive-date-list entries))) 255 (index-entries (top-ten entries))) 256 (funcall (or generator (make-generator)) 257 index-entries pages 258 :twitter-card twitter-card 259 :enable-rss enable-rss 260 :archive-date-list archive-date-list)))) 261 262 (defun gen-month (entries year month pages &key generator archive-date-list enable-rss twitter-card) 263 "Generate a page with all posts for the given year and month" 264 (let ((archive-date-list (or archive-date-list 265 (get-archive-date-list entries)))) 266 (let* ((entries-at-month (monthcdr entries year month)) 267 (collected (collect-entries-for-month 268 entries-at-month year month)) 269 (month-entries (car collected)) 270 (rest-entries (cdr collected))) 271 (cons 272 (if month-entries 273 (list year month 274 (funcall (or generator (make-generator)) 275 month-entries pages 276 :year year 277 :month month 278 :twitter-card twitter-card 279 :enable-rss enable-rss 280 :archive-date-list archive-date-list)) 281 nil) 282 rest-entries)))) 283 284 (defun gen-post (entry pages &key generator archive-date-list enable-rss twitter-card) 285 "Generate a single post page" 286 (funcall (or generator (make-generator)) 287 (list entry) pages 288 :twitter-card twitter-card 289 :enable-rss enable-rss 290 :archive-date-list archive-date-list)) 291 292 (defun gen-page (entry path pages &key generator archive-date-list enable-rss twitter-card) 293 "Generate a single page" 294 (funcall (or generator (make-page-generator)) 295 entry path pages 296 :twitter-card twitter-card 297 :enable-rss enable-rss 298 :archive-date-list archive-date-list))