Here is my static website maintenance tool written in Scheme. Its functionality is mostly achieved by writing website-specific code, so users of this tool need to be able to write code in Scheme. Nevertheless, it is a good fit for a number of tasks on hand-written websites: it can be used to enforce a common format of web pages, automatically update tables of contents from headers, check validity of links, and maintain navigation links between pages.
|
Contents
|
Sweb operates on a directory tree that contains HTML or XHTML files
representing a website. It looks to a .sweb website
subdirectory for plug-ins (files with .scm extension) and
evaluate them. Then it runs process-xhtml-file-hook for every
HTML page found in the directory tree. This causes plug-in functions
registered in process-xhtml-file-hook to be called for every
page.
Freshly installed Sweb provides only basic functions and minimal framework to run the plug-ins. The plug-ins themselves must analyze and change the HTML code as required.
Sweb is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version.
The source code of released versions can be downloaded from ftp://ftp.klic.name/sweb.
The source code repository with the latest development code and history is publicly available via Git.
To get the source code of the development version, run:
$ git clone git://klic.name/sweb.git
To browse the source code online, visit gitweb interface for Sweb.
Sweb requires Guile, a Scheme intepreter. It has been tested and
developed using the guile-1.8.7-6.fc14.i686 package in
Fedora 14 and it works well there.
lines->string linesConverts a list of lines without newline character to a single string. The lines are joined using the newline character.
string->lines stringConverts a string into a list of lines. The newline character is not included in the resulting lines.
read-what-now optionsAsks user what do do now. The only accepted input is any of the characters specified in the string options. Returns the input provided by user — a string consisting of single character.
relative-path from toFind a relative path from one file to another file. Return #f if from and to are same.
Examples:
(relative-path "a.xhtml" "b.xhtml") ⇒ "b.xhtml" (relative-path "a/a.xhtml" "b.xhtml") ⇒ "../b.xhtml" (relative-path "a.xhtml" "b/b.xhtml") ⇒ "b/b.xhtml" (relative-path "a/b/c.xhtml" "a/d/b.xhtml") ⇒ "../d/b.xhtml"
page-parent-page filenameReturns the immediate parent page of a page. Returns #f if no such page exists. That means that filename is the toplevel page.
Examples:
(page-parent-page "computer/emacs/varia.xhtml") ⇒ "computer/emacs/index.xhtml" (page-parent-page "computer/emacs/index.xhtml") ⇒ "computer/index.xhtml" (page-parent-page "computer/index.xhtml") ⇒ "index.xhtml" (page-parent-page "index.xhtml") ⇒ #f
line-index regexp linesFinds a line matching regexp in a list of file lines, and returns its offset. If such a line is not found, #f is returned.
line-block-match begin-regexp end-regexp linesSearch lines for a block starting with a line that
matches begin-regexp and ending with a line that
matches end-regexp. Returns a list that has the text of block
as the first item (the lines are joined by \n), the start
line index (offset to the lines list) as the second item, and
count of the lines in the block as the third item.
(line-block-match "<table>" "</table>"
'("Some line"
"<table> test"
"contents"
"</table>"))
⇒
("<table> test\ncontents\n</table>" 1 3)
list-insert lst offset itemCreate a new list from provided lst by inserting the item to the selected offset. Return the new list.
list-replace lst offset itemCreate a new list from provided lst by replacing the item on the selected offset. Return the new list.
string-join-recursive lstJoin a list of strings and other lists to a single string recursively.
Example:
(string-join-recursive '("a" "b" ("c" ("d" "e") "fg"))) ⇒ "abcdefg"
code-change-query name params header-code change change-code ignore ignore-codeGenerate a function that queries user whether some HTML code change should be performed.
Example:
(code-change-query header-id-not-correct (line ideal-line) (begin (display "Header line is not correct.\n") (format #t " Found: ~A\n" line) (format #t "Expected: ~A\n" ideal-line)) "fix the line" ideal-line "ignore the line" line)
process-xhtml-file-hookScheme hook with arity 3. This hook is run for every XHTML file.
Parameters:
(define (same-title-and-h1 lines dir filename)
(let* ((lines-string (lines->string lines))
(title-match (string-match "<title>(.*)</title>" lines-string))
(h1-match (string-match "<h1>(.*)</h1>" lines-string)))
(unless title-match (display "error: Unable to find title\n"))
(unless h1-match (display "error: Unable to find h1\n"))
(if (and title-match h1-match)
(let ((title (match:substring title-match 1))
(h1 (match:substring h1-match 1)))
;; Offer title synchronization if title and the top level
;; header differ. Differences caused by tags in h1 and not
;; present in title must be ignored, because title cannot
;; contain tags.
(if (and (not (string=? title h1)) (not (string-contains h1 "<")))
(begin
(format #t "Title and h1 do not match:\n~s\n~s\n" title h1)
(display "*** Commands ***\n")
(format #t " 1: synchronize to [t]itle: ~s\n" title)
(format #t " 2: synchronize to [h]1: ~s\n" h1)
(display " 3: [i]gnore for this run\n")
(display " 9: [q]uit\n")
(case (read-what-now "1239thiq")
((#\1 #\t) (string->lines (string-append (substring lines-string 0 (match:start h1-match 1))
title
(substring lines-string (match:end h1-match 1)))))
((#\2 #\h) (string->lines (string-append (substring lines-string 0 (match:start title-match 1))
h1
(substring lines-string (match:end title-match 1)))))
((#\3 #\i) lines)
((#\9 #\q) (display "Bye.\n") (exit 0))
(else (display "What?\n"))))
lines))
;; Return the input if no change occured.
lines)))
(add-hook! process-xhtml-file-hook same-title-and-h1)
;; Find <title>...</title> in current-input-port, and return the
;; contents. Return #f if title is not found.
(define (find-title-in-input)
(if (eof-object? (peek-char (current-input-port)))
#f
(let* ((line (read-line (current-input-port)))
(title-match (string-match "<title>(.*)</title>" line)))
(if title-match
(match:substring title-match 1)
(find-title-in-input)))))
;; Finds the navigation line in a list of lines, and returns its
;; offset. Returns #f if no navigation line is found.
(define (find-navigation-line lines)
(let* ((hr-reversed (list-index (lambda (line) (string-match "<hr */?>" line))
(reverse lines)))
(hr (if hr-reversed
(- (length lines) hr-reversed 1)
#f)))
(if hr
(if (string-match "<a href=.*</a>" (list-ref lines (1+ hr)))
(1+ hr)
#f)
#f)))
(define* (page-navigation-line dir filename #:optional (top-filename filename))
(let ((parent-page (page-parent-page filename)))
(if parent-page
(let* ((full-parent-page (string-append dir "/" parent-page))
(parent-title (if (string= parent-page "index.xhtml")
"Homepage"
;; Open a (X)HTML file and read and
;; then return the contents of its
;; <title>...</title> tag. If the
;; file does not exist or title was
;; not found return #f.
(catch #t
(lambda () (with-input-from-file full-parent-page find-title-in-input))
(lambda (key . args) #f))))
(parent-navigation (page-navigation-line dir
parent-page
top-filename)))
(if parent-title
(let* ((path-to-parent (relative-path top-filename parent-page))
(link-to-parent (string-append "<a href=\"" path-to-parent "\">" parent-title "</a>")))
(if (string= parent-navigation "")
link-to-parent
(string-append link-to-parent ", " parent-navigation)))
parent-navigation))
"")))
(code-change-query navigation-line-not-correct
(lines ideal-line current-line-offset)
(begin
(display "Navigation line is not correct.\n")
(format #t " Found: ~A\n" (list-ref lines current-line-offset))
(format #t "Expected: ~A\n" ideal-line))
"fix the line"
(list-replace lines current-line-offset ideal-line)
"ignore the broken line"
lines)
(define (navigation-links lines dir filename)
(if (string=? filename "index.xhtml")
lines ;; no navigation for title page
(let* ((ideal-line (page-navigation-line dir filename))
(navigation-line-offset (find-navigation-line lines)))
(if navigation-line-offset
(if (string=? ideal-line (list-ref lines navigation-line-offset))
lines
(navigation-line-not-correct-query lines ideal-line navigation-line-offset))
(begin
(display "Navigation line was not found.\n")
lines)))))
(add-hook! process-xhtml-file-hook navigation-links)
;;; Tell the user that the include line was not found, and ask what to
;;; do. Return the list of lines, either modified or unmodified,
;;; depending on user's selection.
;;;
;;; 'lines' is a list of lines in a file
;;; 'ideal-line' is a string with the line proposed for inclusion
;;; 'title-line-offset' is an offset to lines pointing to the <title> line
(code-change-query css-line-not-found
(lines ideal-line title-line-offset)
(display "CSS style sheet line was not found.\n")
"add the line"
(list-insert lines (1+ title-line-offset) ideal-line)
"ignore the missing line"
lines)
;;; Tell the user that the include line does not look like it should,
;;; and ask what to do. Return the list of lines, either modified or
;;; unmodified, depending on user's selection.
;;;
;;; 'lines' is a list of lines in a file
;;; 'ideal-line' is a string with the line proposed for inclusion
;;; 'current-line-offset' is an offset to lines pointing to the
;;; current CSS line
(code-change-query css-line-not-correct
(lines ideal-line current-line-offset)
(begin
(display "CSS line is not correct.\n")
(format #t " Found: ~A\n" (list-ref lines current-line-offset))
(format #t "Expected: ~A\n" ideal-line))
"fix the line"
(list-replace lines current-line-offset ideal-line)
"ignore the broken line"
lines)
;;; Return a string showing how the CSS include line should look for
;;; a file.
(define (ideal-css-link-line filename)
(string-append " <link rel=\"stylesheet\" type=\"text/css\" href=\""
(relative-path filename "")
"site.css\"/>"))
;;; Check CSS style sheet include lines.
(define (css-paths lines dir filename)
(let ((current-line-offset (line-index "<link +rel=\"stylesheet\".*>" lines))
(ideal-line (ideal-css-link-line filename)))
(if current-line-offset
(if (string=? (list-ref lines current-line-offset) ideal-line)
lines
(css-line-not-correct-query lines ideal-line current-line-offset))
(let ((title-line-offset (line-index "<title>.*</title>" lines)))
(if title-line-offset
(css-line-not-found-query lines ideal-line title-line-offset)
(begin
(display "Unable to add CSS style sheet line because the title line was not found.")
lines))))))
(add-hook! process-xhtml-file-hook css-paths)
;;; Tell the user that the include line was not found, and ask what to
;;; do. Return the list of lines, either modified or unmodified,
;;; depending on user's selection.
;;;
;;; 'lines' is a list of lines in a file
;;; 'ideal-line' is a string with the line proposed for inclusion
;;; 'css-line-offset' is an offset to lines pointing to the <link
;;; rel="stylesheet".../> line
(code-change-query js-line-not-found
(lines ideal-line css-line-offset)
(display "Javascript include line was not found.\n")
"add the line"
(list-insert lines (1+ css-line-offset) ideal-line)
"ignore the missing line"
lines)
;;; Tell the user that the include line does not look like it should,
;;; and ask what to do. Return the list of lines, either modified or
;;; unmodified, depending on user's selection.
;;;
;;; 'lines' is a list of lines in a file
;;; 'ideal-line' is a string with the line proposed for inclusion
;;; 'current-line-offset' is an offset to lines pointing to the
;;; current Javascript line
(code-change-query js-line-not-correct
(lines ideal-line current-line-offset)
(begin
(display "Javascript include line is not correct.\n")
(format #t " Found: ~A\n" (list-ref lines current-line-offset))
(format #t "Expected: ~A\n" ideal-line))
"fix the line"
(list-replace lines current-line-offset ideal-line)
"ignore the broken line"
lines)
;;; Check Javascript include lines.
(define (js-paths lines dir filename)
(let ((current-line-offset (line-index "<script +type=\"text/javascript\".*>" lines))
(ideal-line (string-append " <script type=\"text/javascript\" src=\""
(relative-path filename "")
"site.js\"/>")))
(if current-line-offset
(if (string=? (list-ref lines current-line-offset) ideal-line)
lines
(js-line-not-correct-query lines ideal-line current-line-offset))
(let ((css-line-offset (line-index "<link rel=\"stylesheet\".*>" lines)))
(if css-line-offset
(js-line-not-found-query lines ideal-line css-line-offset)
(begin
(display "Unable to add Javascript line because the CSS style sheet line was not found.")
lines))))))
(add-hook! process-xhtml-file-hook js-paths)
(code-change-query header-id-not-correct
(line ideal-line)
(begin
(display "Header line is not correct.\n")
(format #t " Found: ~A\n" line)
(format #t "Expected: ~A\n" ideal-line))
"fix the line"
ideal-line
"ignore the line"
line)
(define (header-id lines dir filename)
(map (lambda (line)
(let* ((match (string-match "<(h[2-9])[^>]*>(.*)</h[2-9]>" line)))
(if match
(let* ((before-header (string-take line (match:start match)))
(after-header (string-drop line (match:end match)))
(head (match:substring match 1))
(title (match:substring match 2))
(downcase-title (string-downcase title))
(id-with-tags (regexp-substitute/global #f "[:_, ]+" downcase-title
'pre "-" 'post))
(id (regexp-substitute/global #f "<[^>]+>" id-with-tags
'pre "" 'post))
(ideal-line (string-join `(,before-header
"<" ,head " id=\"" ,id "\">"
,title
"</" ,head ">"
,after-header) "")))
(if (string<> line ideal-line)
(header-id-not-correct-query line ideal-line)
line))
line)))
lines))
(add-hook! process-xhtml-file-hook header-id)
(define (insert-header-recursive parent-header new-header)
(let* ((parent-header-level (first parent-header))
(parent-header-children (last parent-header))
(new-header-level (first new-header)))
(if (= parent-header-level (- new-header-level 1))
(append (drop-right parent-header 1)
`(,(append parent-header-children `(,new-header))))
(append (drop-right parent-header 1)
`(,(if (= 0 (length parent-header-children))
`(,new-header)
(append (drop-right parent-header-children 1)
`(,(insert-header-recursive (last parent-header-children)
new-header)))))))))
(define (insert-header nested-headers header)
(let ((new-header (append header '(()))))
(if (= 0 (length nested-headers))
(append nested-headers `(,new-header))
(let* ((last-nested-header (last nested-headers))
(last-nested-header-level (first last-nested-header))
(header-level (first new-header)))
(if (>= last-nested-header-level header-level)
(append nested-headers `(,new-header))
(append (drop-right nested-headers 1)
`(,(insert-header-recursive last-nested-header new-header))))))))
(define (html-headers-recursive nested-header prefix depth offset)
(let ((indent (make-string (* 2 depth) #\sp)))
`(,indent
"<li><a href=\"" ,(second nested-header) "\">" ,prefix
,(number->string (+ 1 offset)) " " ,(third nested-header) "</a>"
,(if (< 0 (length (fourth nested-header)))
`("\n"
,indent "<ul>\n"
,(fold (lambda (child items)
(append items
`(,(html-headers-recursive child
`(,prefix
,(number->string (+ 1 offset))
".")
(+ 1 depth)
(length items)))))
'()
(fourth nested-header))
,indent "</ul>\n"
,indent)
"")
"</li>\n")))
(define (toc-from-nested-headers nested-headers)
(string-join-recursive `("<table id=\"toc\" class=\"toc\"><tr><td>\n"
"<div id=\"toctitle\">Contents</div>\n"
"<ul>\n"
,(fold (lambda (header html-headers)
(append html-headers
`(,(html-headers-recursive header "" 0 (length html-headers)))))
'() nested-headers)
"</ul>\n"
"</td></tr></table>")))
(define (new-toc-from-lines lines)
(let* ((headers (filter (lambda (line) (string-match "<h[2-9] id=\".*\">.*</h[2-9]>" line))
lines))
(parsed-headers (map (lambda (line)
(let* ((match (string-match "<h([2-9]) id=\"(.*)\">(.*)</h[2-9]>" line)))
`(,(string->number (match:substring match 1))
,(string-append "#" (match:substring match 2))
,(match:substring match 3))))
headers))
(nested-headers (fold (lambda (header nested-headers)
(insert-header nested-headers header))
'()
parsed-headers)))
(toc-from-nested-headers nested-headers)))
(code-change-query table-of-contents-not-correct
(lines existing-toc new-toc)
(begin
(display "Table of Contents is not correct.\n")
(format #t "Found (lines ~A to ~A):\n~A\n\n"
(second existing-toc)
(+ (second existing-toc) (- (third existing-toc) 1))
(first existing-toc))
(format #t "Expected:\n~A\n\n" new-toc))
"fix the table"
(append (list-head lines (second existing-toc))
(string-split new-toc #\nl)
(list-tail lines (+ (second existing-toc)
(third existing-toc))))
"ignore the incorrect table"
lines)
;; Maintain table of contents.
(define (table-of-contents lines dir filename)
(let* ((new-toc (new-toc-from-lines lines))
(existing-toc (line-block-match "<table.* id=\"toc\"" "</table>" lines))
(existing-toc-length (third existing-toc))
(existing-toc-text (first existing-toc)))
(if (or (= 0 existing-toc-length)
(string=? existing-toc-text new-toc))
lines ; no change
(table-of-contents-not-correct-query lines existing-toc new-toc))))
(add-hook! process-xhtml-file-hook table-of-contents)
sweb
hatchery), not automatically