process.lisp 7.22 KB
Newer Older
1
;;;; -*-Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 3 4
(in-package :cl-site)

;; Copies/renders static assets (imgs, etc)
5 6
(defun process-static (static-dir output-dir)
  (let ((destination-root (merge-pathnames #P"static/" output-dir))
7 8
        (sources (remove-if #'uiop/filesystem:directory-exists-p
			    (directory (merge-pathnames "**/*.*" static-dir))))
9 10
        static-list)
    (dolist (source sources)
11
      (let* ((relative-path (enough-namestring source static-dir))
12 13 14
             (destination (merge-pathnames relative-path destination-root)))
        (when (pathname-name destination) ;; ignore directories
          (ensure-directories-exist destination)
15 16
	  ;;(format t "~a -> ~a~%" source destination)
	  (when (probe-file destination) (delete-file destination))
17 18 19 20 21 22 23
          (uiop:copy-file source destination)
          (push (cons :location relative-path) static-list))))
    (push (cons :static (nreverse static-list))
	         *global-context*)))

;; process-pages : Copies/renders pages - called last

24 25 26 27 28 29 30 31
(defun render-template (template &optional context output-stream)
  (let ((mustache:*load-path* (cons *PAGES-DIR* mustache:*load-path*))
        (mustache:*default-pathname-type* "html"))
    (mustache:render template context output-stream)))

(defun render-template* (template &optional context)
  (with-output-to-string (output-stream)
    (render-template template context output-stream)))
32

33 34
(defun render-page (content context template-path)
  (let ((output-path (make-pathname :defaults (make-path *OUTPUT-DIR* context t) :type "html")))
35
    (ensure-directories-exist output-path)
36 37 38
    (with-open-file (output-stream output-path
                                   :direction :output
                                   :if-exists :supersede)
39
      (with-output-to-string (string-stream)
40 41 42 43 44 45 46 47
         (let* ((stream (make-broadcast-stream output-stream string-stream))
                (page-context (append (acons :rel-path
                                              (enough-namestring (cdr (assoc :content context)) *pages-dir*)
                                              context)
                                      *global-context*))
                (page-content (render-template* content page-context)))
           (render-template template-path (acons :page-content page-content
                                                 page-context)
48
                            stream))))))
49

50
(def-render-hook preprocess-md-page (content context)
51
  (let* ((md-file (enough-namestring (make-path *pages-dir* context t) *pages-dir*)))
52
     (unless (string= (pathname-type md-file) "md")
53
       (return-from preprocess-md-page (call-next-hook content context)))
54 55 56 57
     (let ((md-content (with-output-to-string
                           (out)
                         (cl-markdown:markdown content :stream out))))
       (call-next-hook md-content context))))
58

59
(def-render-hook preprocess-lisp-page (content context)
60 61
  (let* ((lisp-file (make-path *pages-dir* context t)))
     (unless (string= (pathname-type lisp-file) "lisp")
62
       (return-from preprocess-lisp-page (call-next-hook content context)))
63
     (let (*computed-page-content*)
64 65
       (with-input-from-string (s content)
         (load s))
66
       (let ((headers (getf *computed-page-content* :headers)))
67 68 69 70 71 72
         (call-next-hook (getf *computed-page-content* :html-string)
                         (append (mapcan #'(lambda (key value)
                                             (acons key value nil))
                                         (plist-keys headers)
                                         (plist-values headers))
                                  context))))))
73

74 75 76
(defun process-page (content context)
  (let ((template-path (pathname (merge-pathnames *templates-dir* *DEFAULT-PAGE-TEMPLATE*))))
    (render-page content context template-path)))
77

78 79 80
;; Process news


81
(def-render-hook generate-news (content context)
82
  (let ((page-path (cdr (assoc :content context)))
83
        (content (call-next-hook content context)))
84 85
    (when (and (string= (pathname-name page-path) "news")
               (string= (pathname-type page-path) "md"))
86 87
      (let ((newsbox (generate-news-box-content content)))
         (push (cons :newsbox newsbox) *global-context*)))
88
    content))
89 90 91 92 93 94 95 96 97 98

(defun shallow-copy-object (original)
  (let* ((class (class-of original))
         (copy (allocate-instance class)))
    (dolist (slot (mapcar #'c2mop:slot-definition-name (c2mop:class-slots class)))
      (when (slot-boundp original slot)
        (setf (slot-value copy slot)
              (slot-value original slot))))
    copy))

99
(defun generate-news-box-content (html &key (count 4))
100 101 102 103 104 105 106
  (let ((dom (plump-parser:parse html)))
    (let ((state :start)
          (node (plump:first-child dom))
          (news (plump:make-root))
          (current-news))
      (block done
        (flet ((next-node ()
107
                 (setq node (plump:next-sibling node))
108 109 110 111 112 113
                 (when (null node)
                   ;;(print "DONE")
                   (return-from done))
                 node))
          (loop
             ;;(print state)
114
             ;;(describe node)
115 116
             (ecase state
               (:start
117 118
                (if (and (plump:element-p node)
                         (equalp (plump:tag-name node) "html"))
119
                    (setq state :html
120 121 122 123 124 125 126
                          node (plump:first-child node))
                    ;; else
                    (next-node)))

               (:html
                (if (and (plump:element-p node)
                         (equalp (plump:tag-name node) "body"))
127
                    (setq state :body
128 129 130 131 132 133 134
                          node (plump:first-child node))
                    ;; else
                    (next-node)))

               (:body
                (if (and (plump:element-p node)
                         (equalp (plump:tag-name node) "main"))
135
                    (setq state :main
136 137 138 139
                          node (plump:first-child node))
                    (next-node)))

               (:main
140 141
                (if (and (plump:element-p node)
                         (equalp (plump:tag-name node) "h3"))
142
                    (setq state :read-news-heading)
143
                    (next-node)))
144

145 146 147 148 149 150 151
               (:read-news-heading
                                 
                ;; If enough news, exit
                (when (= (length (plump:children news)) count)
                  (return-from done))
                 
                ;; Start a new one
152
                (setq current-news
153 154 155
                      (plump:make-element news "section"))
                
                (let ((title-node (shallow-copy-object node)))
156
                  (setf (plump:tag-name title-node) "h7")
157 158
                  (plump:append-child current-news title-node))
                (next-node)
159
                (setq state :read-news-content))
160 161 162 163 164 165 166 167
               
               (:read-news-content
                ;; We assume the node is a paragraph and we read its content
                (if (and (plump:element-p node)
                         (equalp (plump:tag-name node) "p"))
                    (progn
                      (plump:append-child current-news (shallow-copy-object node))
                      (next-node)
168
                      (setq state :main))
169 170 171
                    ;; else
                    (next-node)))))))
      (plump:serialize news nil))))
172 173


174 175 176



177 178