demo.lisp 1 ;; CL-WHO demo: The Coad Pit (TCP).
2
3 ;; Utilities:
4 (defmacro with-gensyms ((&rest names) &body body)
5 `(let ,(loop for n in names collect `(,n (gensym)))
6 ,@body))
7
8 (defun concatenate-pathname-dirs (pathname1 pathname2)
9 "The result will be a file with the directories of PATHNAME1 and
10 PATHNAME2 concatenated.
11
12 File names and types of PATHNAMEs are ignored."
13 (let ((dir1 (pathname-directory pathname1))
14 (dir2 (pathname-directory pathname2)))
15 (make-pathname :directory
16 (append dir1 (cdr dir2))
17 :name (pathname-name pathname2)
18 :type (pathname-type pathname2))))
19
20 (defun read-file-lines (pathspec)
21 "Read lines in file pointed to by PATHSPEC one by one and return
22 them in a list."
23 (with-open-file (in pathspec)
24 (loop for line = (read-line in nil :eof)
25 until (eq line :eof)
26 collect line)))
27
28 ;; Part one: code page generation
29
30 ;; A line has two components: a number and its content.
31 (defmacro tcp-line-number (n &optional (padding 0))
32 "Template for the line number."
33 `(cl-who:str (format nil "~vd " ,padding ,n)))
34
35 (defmacro tcp-line-content (line)
36 "Template for the line content."
37 `(cl-who:esc ,line))
38
39 (defmacro tcp-line (number padding content)
40 "Template for the line."
41 `(cl-who:htm
42 (:span :class "line"
43 :id (format nil "L~d" ,number)
44 (:a :href (format nil "#L~d" ,number)
45 :class "lineno"
46 (tcp-line-number ,number ,padding))
47 (:span :class "linecont"
48 (tcp-line-content ,content)))
49 (:br)))
50
51 ;; A code block is a list of lines.
52 (defmacro tcp-block (lines)
53 "Template for generating a code block out of a list of lines."
54 (with-gensyms (i padding line)
55 `(cl-who:htm
56 (:pre :class "coadblock"
57 (loop for ,padding = (length (format nil "~d" (length ,lines)))
58 for ,i = 1 then (1+ ,i)
59 for ,line in ,lines do
60 (tcp-line ,i ,padding ,line))))))
61
62 ;; The header contains a title and some CSS.
63 (defmacro tcp-html-header (title)
64 `(cl-who:htm
65 (:title (cl-who:str ,title))
66 (:style :type "text/css"
67 (cl-who:str "
68 .coadblock {background-color:#e8e8e8;
69 border-style:solid;border-width:1px;padding-left:5px;}
70 .line {float:left; width:100%;}
71 .lineno {font-weight:bold;text-decoration:none;color:black;}
72 .lineno:visited {color:black;}
73 :target {background-color:lightyellow;}"))))
74
75 ;; Print this to output file.
76 (defun write-code-page (title lines out-path)
77 "Write LINES to OUT-PATH as a HTML file."
78 (with-open-file (out out-path
79 :direction :output
80 :if-exists :supersede)
81 (cl-who:with-html-output (out nil
82 :prologue t
83 :indent nil)
84 (cl-who:htm
85 (:html (:head (tcp-html-header title))
86 (:body (:b (cl-who:str title))
87 (tcp-block lines)))))))
88
89 ;; Example:
90 ;;
91 ;; (lines-to-file
92 ;; "A Testes"
93 ;; (loop for i from 1 to 20 collect (format nil "line ~d" i))
94 ;; "/virtual/sites/lucian.mogosanu.ro/randomio/test-who.html")
95
96 ;; Part two: code tree processing
97 ;;
98 ;; We need to:
99 ;;
100 ;; - turn filesystem paths into a walkable tree format;
101 ;;
102 ;; - for each directory, be able to generate an index file containing
103 ;; links to files and subdirectories; and
104 ;;
105 ;; - walk said tree and generate code and index pages.
106
107 ;; A tree is one of the following two things:
108 ;;
109 ;; - a pathname with the NAME set to a string; or
110 ;;
111 ;; - a list whose first element is a pathname with the DIRECTORY set
112 ;; to a path and the NAME is not set; the other list elements are
113 ;; trees.
114 ;;
115 ;; For example: (#p"/" #p"a" (#p"/dir/" #p"b" #p"c") #p"d")
116
117 (defun extract-tree (pathspec)
118 "Recursively extract a tree from PATHSPEC."
119
120 ;; If PATHSPEC is not a pathname, turn it into one.
121 (when (stringp pathspec)
122 (setq pathspec (pathname pathspec)))
123
124 ;; Determine the type of node we're dealing with
125 (let ((dir (pathname-directory pathspec))
126 (name (pathname-name pathspec))
127 (type (pathname-type pathspec)))
128 (cond
129 (name (make-pathname :name name :type type))
130 (dir (let ((files (directory (make-pathname :directory dir
131 :name :wild
132 :type :wild))))
133 (cons pathspec
134 (mapcar #'extract-tree files)))))))
135
136 (defun normalized-tree (tree)
137 "Normalize TREE by removing the common part of the path in all
138 directories.
139
140 This function assumes TREE was obtained using EXTRACT-TREE."
141 (let ((root-pathspec (car tree)))
142 (labels ((recurse (tree)
143 ;; This doesn't do anything for non-directory files.
144 (when (pathnamep tree)
145 (return-from recurse tree))
146 (let ((dircopy (copy-list
147 (pathname-directory root-pathspec)))
148 (curr-dir (pathname-directory (car tree))))
149 ;; Get rid of common parts...
150 (loop until (null dircopy) do
151 (pop dircopy)
152 (pop curr-dir))
153 ;; Set normalized path
154 (push :absolute curr-dir)
155 ;; Now recurse into the rest of the tree
156 (cons (make-pathname :directory curr-dir)
157 (mapcar #'(lambda (tree)
158 (recurse tree))
159 (cdr tree))))))
160 (recurse tree))))
161
162 (defmacro tcp-html-path (dir name type)
163 `(make-pathname :directory ,dir
164 :name (format nil "c-~a~@[.~a~]" ,name ,type)
165 :type "html"))
166
167 ;; Links to files...
168 (defmacro tcp-file-link (parent-pathspec pathspec &key (uri-prefix #p"/"))
169 (with-gensyms (dir name type)
170 `(let ((,dir (pathname-directory ,parent-pathspec))
171 (,name (pathname-name ,pathspec))
172 (,type (pathname-type ,pathspec)))
173 (cl-who:htm
174 (:em (cl-who:str "[f] "))
175 (:a :class "filelink"
176 :href (namestring (merge-pathnames
177 (concatenate-pathname-dirs ,uri-prefix
178 ,parent-pathspec)
179 (tcp-html-path ,dir ,name, type)))
180 (cl-who:esc
181 (format nil "~a~@[.~a~]" ,name ,type)))))))
182
183 ;; and to directories.
184 (defmacro tcp-directory-link (pathspec &key (uri-prefix #p"/")
185 custom-name)
186 `(cl-who:htm
187 (:em (cl-who:str "[d] "))
188 (:a :class "dirlink"
189 :href (namestring (concatenate-pathname-dirs ,uri-prefix ,pathspec))
190 (cl-who:esc (or ,custom-name
191 (car (last (pathname-directory ,pathspec))))))))
192
193 (defun parent-dir (pathspec)
194 "Given PATHSPEC to directory, get parent node, e.g.:
195
196 - /home/bubu/ -> /home/
197 - / -> /
198
199 Only the DIRECTORY component of PATHSPEC is considered, all others are
200 ignored."
201 (labels ((all-but-last (L)
202 (cond
203 ((null L) (error "Empty list."))
204 (t (loop for curr-L on L
205 while (cdr curr-L)
206 collect (car curr-L))))))
207 (let ((dir (pathname-directory pathspec)))
208 (make-pathname :directory
209 (if (null (cdr dir))
210 dir
211 (all-but-last dir))))))
212
213 ;; Generate an index for a given directory.
214 (defmacro tcp-index (tree &optional (uri-prefix #p"/"))
215 (with-gensyms (parent-pathspec curr-pathspec children subtree)
216 `(let* ((,curr-pathspec (car ,tree))
217 (,children (cdr ,tree))
218 (,parent-pathspec (parent-dir ,curr-pathspec)))
219 (cl-who:htm
220 (:pre :class "coadblock"
221 ;; First link is self
222 (tcp-directory-link ,curr-pathspec
223 :uri-prefix ,uri-prefix
224 :custom-name ".")
225 (:br)
226 ;; Second link is the parent
227 (tcp-directory-link ,parent-pathspec
228 :uri-prefix ,uri-prefix
229 :custom-name"..")
230 (:br)
231
232 ;; All the others are the files/subdirectories
233 (loop for ,subtree in ,children do
234 (cond
235 ((pathnamep ,subtree) (tcp-file-link
236 ,curr-pathspec
237 ,subtree
238 :uri-prefix ,uri-prefix))
239 ((listp ,subtree) (tcp-directory-link
240 (car ,subtree)
241 :uri-prefix ,uri-prefix))
242 (t (error "Not a tree.")))
243 (cl-who:htm (:br))))))))
244
245 ;; To generate HTML pages for a given codebase, we need the following
246 ;; information:
247 ;;
248 ;; - the (relative, normalized) path information for all the files;
249 ;; - an optional URI prefix for hrefs residing downstream in the site;
250 ;; - the path to the root of the input directory; and
251 ;; - the path to the root of the output directory.
252 ;;
253 ;; We capture those in the tcp-info struct:
254 (defstruct (tcp-info (:constructor make-tcp-info%))
255 in-pathspec out-pathspec uri-prefix tree)
256
257 (defun make-tcp-info (in-pathspec out-pathspec &optional (uri-prefix #p"/"))
258 "Create info structre for HTML coadpage generation."
259 (let ((in-tree (extract-tree in-pathspec)))
260 (make-tcp-info% :in-pathspec in-pathspec
261 :out-pathspec out-pathspec
262 :uri-prefix uri-prefix
263 :tree (normalized-tree in-tree))))
264
265 ;; Write index page, using all the above helpers.
266 (defun write-index-page (tree tcp-info)
267 "Write TREE to HTML file given by OUT-PATHSPEC in TCP-INFO."
268 ;; Do nothing if TREE is a regular file.
269 (when (pathnamep tree)
270 (return-from write-index-page))
271
272 ;; Do something only if we have a subtree.
273 (assert (listp tree))
274 (let ((out-path (merge-pathnames
275 (concatenate-pathname-dirs (tcp-info-out-pathspec tcp-info)
276 (car tree))
277 "index.html"))
278 (title (format nil "Index for ~a:" (namestring (car tree)))))
279 (with-open-file (out out-path
280 :direction :output
281 :if-exists :supersede
282 :if-does-not-exist :create)
283 (cl-who:with-html-output (out nil
284 :prologue t
285 :indent nil)
286 (cl-who:htm
287 (:html (:head (tcp-html-header title))
288 (:body (:b (cl-who:str title))
289 (tcp-index tree (tcp-info-uri-prefix tcp-info)))))))))
290
291 ;; Now we have the basic ammo to generate everything.
292 (defun generate-coad-pit (tcp-info)
293 "Given TCP-INFO, generate code site."
294 (labels
295 ((recurse (tree parent-pathspec)
296 ;; Are we on a leaf, or...?
297 (cond
298 ;; Read lines and generate code page. Careful, if you're
299 ;; reading from binary files, you're fucked.
300 ((pathnamep tree)
301 (let* ((dir (pathname-directory tree))
302 (name (pathname-name tree))
303 (type (pathname-type tree))
304 (htm-pathspec (tcp-html-path dir name type))
305 (in-pathspec
306 (concatenate-pathname-dirs (tcp-info-in-pathspec tcp-info)
307 (merge-pathnames parent-pathspec
308 tree)))
309 (out-pathspec
310 (concatenate-pathname-dirs (tcp-info-out-pathspec tcp-info)
311 (merge-pathnames parent-pathspec
312 htm-pathspec)))
313 (title (namestring tree))
314 (lines (read-file-lines in-pathspec)))
315 (write-code-page title lines out-pathspec)))
316 ((listp tree)
317 (let* ((pathspec (car tree))
318 (children (cdr tree))
319 (out-pathspec
320 (concatenate-pathname-dirs (tcp-info-out-pathspec tcp-info)
321 pathspec)))
322 (ensure-directories-exist out-pathspec)
323 (write-index-page tree tcp-info)
324 (loop for subtree in children do
325 (recurse subtree pathspec))))
326 (t (error "Not a tree.")))))
327 (recurse (tcp-info-tree tcp-info) #p"/")))