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