...
 
Commits (26)
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2012, 2019 Vladimir Sedach <vsedach@common-lisp.net>
......@@ -19,22 +21,27 @@
(in-package #:cliki2)
(defvar *wiki*)
(defvar *account* nil)
(defvar *WIKI*)
(defvar *ACCOUNT* nil)
(defclass cliki2-acceptor (easy-acceptor)
((dispatch-table :reader dispatch-table :initarg :dispatch-table)
(wikis :reader wikis :initarg :wikis)))
(defmethod acceptor-dispatch-request ((acceptor cliki2-acceptor) request)
(let* ((host (subseq (host) 0 (or (position #\: (host)) (length (host)))))
(*wiki* (cadr (assoc host (wikis acceptor) :test #'string=))))
(defmethod acceptor-dispatch-request
((acceptor cliki2-acceptor) request)
(let ((*WIKI* (cadr
(assoc (subseq (host) 0 (or (position #\: (host))
(length (host))))
(wikis acceptor)
:test (function string=)))))
(setf (header-out "Content-Security-Policy")
"default-src 'none'; style-src 'self' 'unsafe-inline'; img-src *; form-action 'self';")
(if *wiki*
(let ((*account* (account-auth)))
(loop for dispatcher in (dispatch-table acceptor)
for action = (funcall dispatcher request)
when action return (funcall action)
finally (call-next-method)))
(if *WIKI*
(let ((*ACCOUNT* (account-auth)))
(dolist (dispatcher (dispatch-table acceptor)
(call-next-method))
(let ((action (funcall dispatcher request)))
(when action
(return (funcall action))))))
(call-next-method))))
This diff is collapsed.
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2011, 2012 Vladimir Sedach <vsedach@common-lisp.net>
;;; Copyright 2011, 2012, 2019 Vladimir Sedach <vsedach@common-lisp.net>
;;; SPDX-License-Identifier: AGPL-3.0-or-later
......@@ -21,8 +23,7 @@
(in-readtable cliki2)
(defun cut-whitespace (str)
(string-trim #(#\Space #\Tab #\Newline #\Return)
(ppcre:regex-replace-all "\\s+" str " ")))
(string-trim " " (ppcre:regex-replace-all "\\s+" str " ")))
;;; article
......@@ -34,15 +35,21 @@
(equal "" (cached-content (article-title article))))
(defun article-link (x)
(format nil "/~A" (uri-encode (cut-whitespace x))))
(concatenate 'string "/" (uri-encode (cut-whitespace x))))
(defun latest-revision (article)
(car (revisions article)))
(defun %print-article-link (title class &optional (display-title title))
(let* ((article (find-article title))
(class (if (and article (not (deleted? article))) class "new")))
#H[<a href="${ (article-link title) }" class="${ class }">${ (escape-for-html display-title) }</a>]))
(defun %print-article-link (title class
&optional (display-title title))
(let ((article (find-article title)))
(HTML "<a href=\""(article-link title)"\" class=\""
(if (and article (not (deleted? article)))
class
"new")
"\">"
(escape-for-html display-title)
"</a>")))
(defun pprint-article-link (title)
(%print-article-link title "internal"))
......@@ -61,90 +68,153 @@
author-ip)
(defun add-revision (article content summary)
(record-revision (make-revision :parent-title (article-title article)
:revision-date (get-universal-time)
:summary summary
:author-name (if *account*
(account-name *account*)
(real-remote-addr))
:author-ip (real-remote-addr))
(string-trim #(#\Space #\Newline #\Tab)
(remove #\Return content))))
(record-revision
(make-revision :parent-title (article-title article)
:revision-date (get-universal-time)
:summary summary
:author-name (if *ACCOUNT*
(account-name *ACCOUNT*)
(real-remote-addr))
:author-ip (real-remote-addr))
(string-trim #(#\Space #\Newline #\Tab)
(remove #\Return content))))
(defun edit-link (revision text)
#?[<a href="$(#/site/edit-article?title={ (parent-title revision) }&amp;from-revision={ (revision-date revision) })">${ text }</a>])
(concatenate
'string
"<a href=\""
#/site/edit-article?title={(parent-title revision)}&from-revision={(revision-date revision)}
"\">"text"</a>"))
(defun article-footer (revision)
(with-output-to-string (*html-stream*)
(with-output-to-string (*HTML-output*)
(let ((title (parent-title revision)))
#H[<li><a href="${ (article-link title) }">Current version</a></li>
<li><a href="$(#/site/history?article={ title })">History</a></li>
<li><a href="$(#/site/backlinks?article={ title })">Backlinks</a></li>]
(unless (youre-banned?)
#H[<li>${ (edit-link revision "Edit") }</li>]
#H[<li><a href="$(#/site/edit-article?create=t)">Create</a></li>]))))
(HTML "
<li>
<a href=\""(article-link title)"\">Current version</a>
</li>
<li>
<a href=\""#/site/history?article={title}"\">History</a>
</li>
<li>
<a href=\""#/site/backlinks?article={title}"\">Backlinks</a>
</li>")
(defun render-revision (revision &optional (content (revision-content revision)))
(unless (youre-banned?)
(HTML "
<li>
"(edit-link revision "Edit")"
</li>
<li>
<a href=\""#/site/edit-article?create=t"\">Create</a>
</li>")))))
(defun render-revision
(revision &optional (content (revision-content revision)))
(generate-html-from-markup content)
(setf *footer* (article-footer revision)))
(setf *FOOTER* (article-footer revision)))
(defun find-revision (article-title date-string)
(find (parse-integer date-string)
(revisions (find-article article-title :error t))
:key #'revision-date))
(defpage /site/view-revision () (article date)
(let* ((revision (find-revision article date))
(revision-name #?"Revision ${ (rfc-1123-date (revision-date revision)) }"))
(setf *title* #?"${ (escape-for-html article) } ${ revision-name }")
#H[<div class="centered">${ revision-name }</div>]
:key (function revision-date)))
(defpage /site/view-revision "" (article-name date)
(let* ((revision (find-revision article-name date))
(revision-name (concatenate
'string
"Revision "
(rfc-1123-date (revision-date revision)))))
(setf *TITLE* (concatenate
'string
(escape-for-html article-name) " " revision-name))
(HTML "<div class=\"centered\">"revision-name"</div>")
(render-revision revision)))
(defun revision-link (revision)
#/site/view-revision?article={ (parent-title revision) }&date={ (revision-date revision) })
#/site/view-revision?article={(parent-title revision)}&date={(revision-date revision)})
(defun pprint-revision-link (revision)
#H[<a class="internal" href="${ (revision-link revision) }">${ (rfc-1123-date (revision-date revision)) }</a>])
(HTML "<a class=\"internal\" href=\""(revision-link revision)"\">"
(rfc-1123-date (revision-date revision))
"</a>"))
;;; edit article
(defun render-edit-article-common (title content summary &key edit-title error)
(defun render-edit-article-common
(title content summary &key edit-title error)
(if edit-title
#H[<span>Title: </span>
<input type="text" name="title" size="50" value="${title}"/>]
(HTML "<span>Title: </span>
<input type=\"text\"
name=\"title\"
size=\"50\"
value=\""title"\"
/>")
(progn
(setf *title* #?"Editing ${title}")
#H[<h1>Editing '${title}'</h1>]
#H[<input type="hidden" name="title" value="${title}" />]))
#H[<textarea rows="18" cols="80" name="content">${(escape-for-html content)}</textarea>
<dl class="prefs">
<dt><label for="summary">Edit summary:</label></dt>
<dd><input type="text" name="summary" size="50" value="${summary}" /></dd>]
(unless *account*
(setf *TITLE* (concatenate 'string "Editing " title))
(HTML "<h1>Editing '"title"'</h1>
<input type=\"hidden\"
name=\"title\"
value=\""title"\"
/>")))
(HTML "
<textarea rows=\"18\"
cols=\"80\"
name=\"content\"
>"(escape-for-html content)"</textarea>
<dl class=\"prefs\">
<dt>
<label for=\"summary\">Edit summary:</label>
</dt>
<dd>
<input type=\"text\"
name=\"summary\"
size=\"50\"
value=\""summary"\"
/>
</dd>")
(unless *ACCOUNT*
(maybe-show-form-error error t "Wrong captcha answer")
(let ((captcha (make-captcha)))
#H[<dt><label for="captcha">${captcha} is:</label></dt><dd>]
(HTML "
<dt>
<label for=\"captcha\">"captcha" is:</label>
</dt>
<dd>")
(emit-captcha-inputs captcha "" 50)
#H[</dd>]))
(HTML "
</dd>")))
(HTML "
</dl>
<input type=\"submit\"
value=\"Save\"
name=\"save\"
/>
<input type=\"submit\"
value=\"Preview\"
name=\"preview\"
/>")
#H[</dl>
<input type="submit" value="Save" name="save" />
<input type="submit" value="Preview" name="preview" />]
(when content
#H[<h1>Article preview:</h1>]
(HTML "<h1>Article preview:</h1>")
(generate-html-from-markup (remove #\Return content))))
(defpage /site/edit-article () (title content summary from-revision save create)
(defpage /site/edit-article ""
(title content summary from-revision save create)
(let ((maybe-article (find-article title)))
#H[<form method="post" action="$(#/site/edit-article)">]
(HTML "<form method=\"post\" action=\""#/site/edit-article"\">")
(cond
((youre-banned?)
(redirect #/))
(save
(if (and (or *account* (check-captcha))
(if (and (or *ACCOUNT* (check-captcha))
(< 0 (length (cut-whitespace title))))
(progn (add-revision
(or maybe-article
......@@ -161,20 +231,24 @@
:edit-title (not maybe-article) :error t)))
(create
(setf *title* "Create new article")
(setf *TITLE* "Create new article")
(render-edit-article-common "" "" "created page"
:edit-title t))
(t
(render-edit-article-common
title
(cond (content content)
(from-revision (revision-content
(find-revision title from-revision)))
(maybe-article (cached-content title))
(t ""))
(cond (content
content)
(from-revision
(revision-content (find-revision title from-revision)))
(maybe-article
(cached-content title))
(t
""))
(if (and (not maybe-article) (not summary))
"created page"
(or summary ""))
:edit-title (not maybe-article))))
#H[</form>]))
(HTML "</form>")))
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2011, 2012 Vladimir Sedach <vsedach@common-lisp.net>
;;; Copyright 2011, 2012, 2019 Vladimir Sedach <vsedach@common-lisp.net>
;;; SPDX-License-Identifier: AGPL-3.0-or-later
......@@ -26,8 +28,8 @@
password-digest)
(defun logout ()
(with-lock-held ((session-lock *wiki*))
(remhash (cookie-in "cliki2auth") (sessions *wiki*)))
(with-lock-held ((session-lock *WIKI*))
(remhash (cookie-in "cliki2auth") (sessions *WIKI*)))
(set-cookie "cliki2auth" :value "" :path "/")
nil)
......@@ -43,19 +45,22 @@
(defun login (account)
(let (secret)
(with-lock-held ((session-lock *wiki*))
(with-lock-held ((session-lock *WIKI*))
(loop while (gethash (setf secret (make-random-string 60))
(sessions *wiki*)))
(setf (gethash secret (sessions *wiki*))
(sessions *WIKI*)))
(setf (gethash secret (sessions *WIKI*))
(make-session :account account
:expires-at (next-expiry-time)
:password-digest (account-password-digest account))))
(set-cookie "cliki2auth" :value secret :path "/" :expires (next-expiry-time))))
(set-cookie "cliki2auth"
:value secret
:path "/"
:expires (next-expiry-time))))
(defun account-auth ()
(let* ((secret (cookie-in "cliki2auth")))
(awhen (with-lock-held ((session-lock *wiki*))
(gethash secret (sessions *wiki*)))
(awhen (with-lock-held ((session-lock *WIKI*))
(gethash secret (sessions *WIKI*)))
(if (and (< (get-universal-time) (session-expires-at it))
(string= (account-password-digest (session-account it))
(session-password-digest it)))
......@@ -65,24 +70,39 @@
;;; captcha
(defvar captcha-ops '(floor ceiling truncate round))
(defun make-captcha ()
(list (elt captcha-ops (random (length captcha-ops)))
(- (random 40) 20)
(1+ (random 10))))
(defun emit-captcha-inputs (captcha class size)
#H[<input class="${class}" name="captcha-answer" size="${size}" />
<input type="hidden" name="captcha-op" value="${(elt captcha 0)}" />
<input type="hidden" name="captcha-x" value="${(elt captcha 1)}" />
<input type="hidden" name="captcha-y" value="${(elt captcha 2)}" />])
(defun check-captcha ()
(let ((x (parse-integer (parameter "captcha-x") :junk-allowed t))
(y (parse-integer (parameter "captcha-y") :junk-allowed t))
(answer (parse-integer (parameter "captcha-answer") :junk-allowed t))
(op (find (parameter "captcha-op") captcha-ops
:key #'symbol-name :test #'string-equal)))
(when (and op x y answer)
(= (funcall op x y) answer))))
(HTML "
<input class=\""class"\"
name=\"captcha-answer\"
size=\""size"\"
/>
<input type=\""hidden"\"
name=\"captcha-op\"
value=\""(elt captcha 0)"\"
/>
<input type=\"hidden\"
name=\"captcha-x\"
value=\""(elt captcha 1)"\"
/>
<input type=\"hidden\"
name=\"captcha-y\"
value=\""(elt captcha 2)"\"
/>"))
(let ((captcha-ops #(floor ceiling truncate round)))
(defun make-captcha ()
(vector (elt captcha-ops (random (length captcha-ops)))
(- (random 40) 20)
(1+ (random 10))))
(defun check-captcha ()
(let ((x (parse-integer (parameter "captcha-x")
:junk-allowed t))
(y (parse-integer (parameter "captcha-y")
:junk-allowed t))
(answer (parse-integer (parameter "captcha-answer")
:junk-allowed t))
(op (find (parameter "captcha-op") captcha-ops
:key (function symbol-name)
:test (function string-equal))))
(and op x y answer (= answer (funcall op x y))))))
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2012 Vladimir Sedach <vsedach@common-lisp.net>
;;; Copyright 2012, 2019 Vladimir Sedach <vsedach@common-lisp.net>
;;; SPDX-License-Identifier: AGPL-3.0-or-later
......@@ -21,22 +23,36 @@
(in-readtable cliki2)
(defun print-link-list (links printer)
#H[<ul>]
(HTML "<ul>")
(dolist (link links)
#H[<li>] (funcall printer link))
#H[</ul>])
(defpage /site/backlinks () (article)
(let* ((article-obj (find-article article :error t))
(content (cached-content article)))
(setf *title* #?'Link information for "${ (article-title article-obj) }"'
*footer* (article-footer (latest-revision article-obj)))
#H[<h1>Link information for ] (pprint-article-link article) #H[</h1>
Topics:] (print-link-list (topics content) #'pprint-topic-link)
#H[Links to other articles:]
(print-link-list (page-links content) #'pprint-article-link)
#H[Links from other articles:]
(print-link-list (article-backlinks article) #'pprint-article-link)
#H[Articles in '${ article }' topic:]
(print-link-list (articles-by-topic article) #'pprint-article-link)))
(HTML "<li>") (funcall printer link) (HTML "</li>"))
(HTML "</ul>"))
(defpage /site/backlinks "" (article-title)
(let ((article (find-article article-title :error t)))
(setf *TITLE*
(concatenate
'string
"Link information for \""(article-title article)"\"")
*FOOTER*
(article-footer (latest-revision article)))
(let ((content (cached-content (article-title article))))
(HTML "<h1>Link information for ")
(pprint-article-link (article-title article))
(HTML "</h1>
Topics:")
(print-link-list (topics content)
(function pprint-topic-link))
(HTML "
Links to other articles:")
(print-link-list (page-links content)
(function pprint-article-link))
(HTML "
Links from other articles:")
(print-link-list (article-backlinks (article-title article))
(function pprint-article-link))
(HTML "
Articles in '"(article-title article)"' topic:")
(print-link-list (articles-by-topic (article-title article))
(function pprint-article-link)))))
This diff is collapsed.
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2011, 2012 Vladimir Sedach <vsedach@common-lisp.net>
;;; Copyright 2011, 2012, 2019 Vladimir Sedach <vsedach@common-lisp.net>
;;; SPDX-License-Identifier: AGPL-3.0-or-later
......@@ -24,24 +26,33 @@
(subseq (url-decode (script-name*)) 1))
(defun show-deleted-article-page (article)
(setf (return-code*)
404
*footer*
(with-output-to-string (*html-stream*)
#H[<li><a href="$(#/site/history?article={ (article-title article) })">History</a></li>]))
#H[Article was deleted])
(setf (return-code*) 404
*FOOTER* (concatenate 'string "
<li>
<a href=\""#/site/history?article={(article-title article)}
"\">History</a>
</li>"))
(HTML "Article was deleted"))
(defun render-article (article
&optional (page-title (article-title article)))
(let ((*header* #?[<link rel="alternate" type="application/atom+xml" title="ATOM feed of edits to current article"
href="$(#/site/feed/article.atom?title={ (article-title article) })">]))
(let ((*HEADER*
(concatenate 'string "
<link rel=\"alternate\"
type=\"application/atom+xml\"
title=\"ATOM feed of edits to current article\"
href=\""#/site/feed/article.atom?title={(article-title article)}"\"
>")))
(render-page page-title
(if (deleted? article)
(show-deleted-article-page article)
(progn
#H[<div id="article-title">${ (article-title article) }</div>]
(render-revision (latest-revision article)
(cached-content (article-title article))))))))
(HTML "<div id=\"article-title\">"
(article-title article)
"</div>")
(render-revision
(latest-revision article)
(cached-content (article-title article))))))))
(defun article-dispatcher (request)
(lambda ()
......@@ -50,24 +61,29 @@
((not article)
(setf (return-code*) 404)
(render-page "Article not found"
#H[<h1>Article not found</h1>
<a href="$(#/site/edit-article?title={(guess-article-name)})">Create</a>]))
(HTML "
<h1>Article not found</h1>
<a href=\""
#/site/edit-article?title={(guess-article-name)}
"\">Create</a>")))
((get-parameter "download" request)
(redirect (elt
(nth-value
1
(ppcre:scan-to-strings
#?/_P\((.*?)\)/ (cached-content (article-title article))))
0)))
(redirect
(elt
(nth-value
1
(ppcre:scan-to-strings
#?/_P\((.*?)\)/
(cached-content (article-title article))))
0)))
(t (render-article article))))))
(defmethod acceptor-status-message :around ((acceptor cliki2-acceptor)
status-code &key &allow-other-keys)
(unless (and (equal status-code 404) (not (boundp '*wiki*)))
(defmethod acceptor-status-message :around
((acceptor cliki2-acceptor) status-code &key &allow-other-keys)
(unless (and (equal status-code 404) (not (boundp '*WIKI*)))
(call-next-method)))
(define-easy-handler (root :uri "/") ()
(render-article (find-article "index") (description *wiki*)))
(render-article (find-article "index") (description *WIKI*)))
(%defpage /robots.txt :both ()
"User-agent: *
......
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2011, 2012 Vladimir Sedach <vsedach@common-lisp.net>
;;; Copyright 2011, 2012, 2019 Vladimir Sedach <vsedach@common-lisp.net>
;;; SPDX-License-Identifier: AGPL-3.0-or-later
......@@ -22,59 +24,130 @@
(defun output-undo-button (revision)
(unless (youre-banned?)
#H[<input type="hidden" name="undo-revision" value="${ (revision-date revision) }" />
(<input type="submit" name="undo" value="undo" class="undo" />)]))
(HTML "
<input type=\"hidden\"
name=\"undo-revision\"
value=\""(revision-date revision)"\"
/>
(<input type=\"submit\"
name=\"undo\"
value=\"undo\"
class=\"undo\"
/>)")))
(defun output-compare-link (old new text)
#H[(<a class="internal" href="$(#/site/compare-revisions?article={ (parent-title new) }&old={ (revision-date old) }&diff={ (revision-date new) })">${text}</a>)])
(HTML "
(<a class=\"internal\"
href=\""
#/site/compare-revisions?article={(parent-title new)}&old={(revision-date old)}&diff={(revision-date new)}
"\">" text "</a>)"))
(defpage /site/history () (article)
(defpage /site/history "" (article)
(let ((article-obj (find-article article :error t)))
(setf *title* #?'History of article: "${ (article-title article-obj) }"'
*header* #?[<link rel="alternate" type="application/atom+xml" title="article changes" href="$(#/site/feed/article.atom?title={ (article-title article-obj) })">]
*footer* (article-footer (latest-revision article-obj)))
#H[<h1>History of article ] (pprint-article-link article) #H[</h1>
<a class="internal" href="$(#/site/feed/article.atom?title={ (article-title article-obj) })">ATOM feed</a>
<form method="post" action="$(#/site/history-with-undo)">
<input type="hidden" name="article" value="${ article }" />
<input type="submit" value="Compare selected versions" />
<table id="pagehistory">]
(loop for rhead on (revisions article-obj)
for revision = (car rhead)
for author = (author-name revision)
for first = t then nil do
(flet ((radio (x)
#H[<td><input type="radio" name="${x}" value="${ (revision-date revision) }" /></td>]))
#H[<tr><td>]
(awhen (cadr rhead)
(output-compare-link it revision "prev"))
#H[</td>]
(radio "old") (radio "diff")
#H[<td>] (pprint-revision-link revision)
#H[ ${ (account-link author) } (<em>${ (escape-for-html (summary revision)) }</em>) ]
(setf *TITLE* (concatenate 'string
"History of article: \""
(article-title article-obj)
"\"")
*HEADER* (concatenate
'string
"
<link rel=\"alternate\"
type=\"application/atom+xml\"
title=\"article changes\"
href=\""#/site/feed/article.atom?title={(article-title article-obj)}"\"
>")
*FOOTER* (article-footer (latest-revision article-obj)))
(HTML "<h1>History of article ")
(pprint-article-link article)
(HTML "</h1>
<a class=\"internal\"
href=\""
#/site/feed/article.atom?title={(article-title article-obj)}
"\"
>ATOM feed</a>
<form method=\"post\"
action=\""#/site/history-with-undo"\"
>
<input type=\"hidden\"
name=\"article\"
value=\""article"\"
/>
<input type=\"submit\"
value=\"Compare selected versions\"
/>
<table id=\"pagehistory\">")
(do ((remaining-revisions
(revisions article-obj) (rest remaining-revisions))
(first t nil))
((endp remaining-revisions))
(let ((revision (first remaining-revisions)))
(HTML "
<tr>
<td>")
(when (second remaining-revisions)
(output-compare-link
(second remaining-revisions) revision "prev"))
(HTML "
</td>")
(flet ((radio (name)
(HTML "
<td>
<input type=\"radio\"
name=\""name"\"
value=\""(revision-date revision)"\"
/>
</td>")))
(radio "old")
(radio "diff"))
(HTML "
<td>")
(pprint-revision-link revision)
(HTML
" "(account-link (author-name revision))" "
"(<em>"(escape-for-html (summary revision))"</em>) ")
(when first
(output-undo-button revision))
#H[</td></tr>]))
#H[</table>
<input type="submit" value="Compare selected versions" />
</form>]))
(HTML "
</td>
</tr>")))
(HTML "
</table>
<input type=\"submit\"
value=\"Compare selected versions\"
/>
</form>")))
;;; undo
(defpage /site/not-latest "Revision not the latest" (article)
#H[Can't undo this revision because it is not the latest.
<a href="$(#/site/history?article={article})">Go back to history page</a>.])
(HTML "
Cannot undo this revision because it is not the latest.
<a href=\""#/site/history?article={article}"\">Go back to history page</a>."))
(defun undo-latest-revision (article)
(let ((revision (first (revisions article)))
(restored-revision (second (revisions article))))
(when restored-revision
(add-revision
article (revision-content restored-revision)
#?"undid last revision by ${ (author-name revision) }"))))
article
(revision-content restored-revision)
(concatenate 'string
"undid last revision by "
(author-name revision))))))
(defun undo-revision (article-title revision-date)
(let ((revision (find-revision article-title revision-date))
......
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2011, 2012, 2019 Vladimir Sedach <vsedach@common-lisp.net>
......@@ -20,78 +22,147 @@
(in-package #:cliki2)
(in-readtable cliki2)
(defvar *title* "")
(defvar *footer* "")
(defvar *header* "")
(defvar *TITLE* "")
(defvar *FOOTER* "")
(defvar *HEADER* "")
(defun HTML (&rest args)
(dolist (x args)
(if (stringp x)
(write-string x *HTML-output*)
(princ x *HTML-output*))))
(defun render-header ()
#H[<!DOCTYPE html>
(HTML "<!DOCTYPE html>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<title>${(format nil "~A~@[: ~A~]" (wiki-name *wiki*) *title*)}</title>
${*header*}
<link rel="stylesheet" href="/static/css/style.css">
<link rel="stylesheet" href="/static/css/colorize.css">
<meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\">
<title>"(wiki-name *WIKI*)": "*TITLE*"</title>
"*HEADER*"
<link rel=\"stylesheet\" href=\"/static/css/style.css\">
<link rel=\"stylesheet\" href=\"/static/css/colorize.css\">
</head>
<body>
<span class="hidden">${ (wiki-name *wiki*) } - ${*title*}</span>
<div id="content"><div id="content-area">])
<span class=\"hidden\">"(wiki-name *WIKI*)" - "*TITLE*"</span>
<div id=\"content\">
<div id=\"content-area\">
"))
(defun render-footer ()
#H[</div>
<div id="footer" class="buttonbar"><ul>${*footer*}</ul></div>
</div>
<div id="header-buttons" class="buttonbar">
<ul>
<li><a href="/">Home</a></li>
<li><a href="$(#/site/recent-changes)">Recent Changes</a></li>
<li><a href="/${(wiki-name *wiki*)}">About</a></li>
<li><a href="/Text%20Formatting">Text Formatting</a></li>
<li><a href="$(#/site/tools)">Tools</a></li>
</ul>
<div id="search">
<form action="$(#/site/search)">
<label for="search_query" class="hidden">Search ${(wiki-name *wiki*)}</label>
<input type="text" name="query" id="search_query" value="${(escape-for-html (or (get-parameter "query") ""))}" />
<input type="submit" value="search" />
</form>
</div>
(HTML "
</div>
<div id=\"footer\"
class=\"buttonbar\"
>
<ul>"
*FOOTER*"
</ul>
</div>
</div>
<div id=\"header-buttons\"
class=\"buttonbar\"
>
<ul>
<li>
<a href=\"/\">Home</a>
</li>
<li>
<a href=\""#/site/recent-changes"\">Recent Changes</a>
</li>
<li>
<a href=\"/"(wiki-name *WIKI*)"\">About</a>
</li>
<li>
<a href=\"/Text%20Formatting\">Text Formatting</a>
</li>
<li>
<a href=\""#/site/tools"\">Tools</a>
</li>
</ul>
<div id=\"search\">
<form action=\""#/site/search"\">
<label for=\"search_query\"
class=\"hidden\">Search "(wiki-name *WIKI*)"
</label>
<input type=\"text\"
name=\"query\"
id=\"search_query\"
value=\""(escape-for-html (or (get-parameter "query") ""))"\"
/>
<input type=\"submit\"
value=\"search\"
/>
</form>
</div>
<div id="pageheader">
<div id="header">
<span id="logo">${(wiki-name *wiki*)}</span>
<span id="slogan">${(description *wiki*)}</span>
<div id="login">]
(if *account*
#H[<div id="logout">
<span>${(account-link (account-name *account*))}</span>
<div id="logout_button"><a href="$(#/site/logout)">Log out</a></div>
</div>]
#H[<form method="post" action="$(#/site/login)">
<label for="login_name" class="hidden">Account name</label>
<input type="text" name="name" id="login_name" class="login_input" />
<label for= "login_password" class="hidden">Password</label>
<input type="password" name="password" id="login_password" class="login_input" />
<input type="submit" name="login" value="login" id="login_submit" /><br />
<div id="register"><a href="$(#/site/register)">register</a></div>
<input type="submit" name="reset-pw" value="reset password" id="reset_pw" />
</form>])
#H[
</div>
</div>
<div id=\"pageheader\">
<div id=\"header\">
<span id=\"logo\">"(wiki-name *WIKI*)"</span>
<span id=\"slogan\">"(description *WIKI*)"</span>
<div id=\"login\">")
(if *ACCOUNT*
(HTML "
<div id=\"logout\">
<span>"(account-link (account-name *ACCOUNT*))"</span>
<div id=\"logout_button\">
<a href=\""#/site/logout"\">Log out</a>
</div>
</div>")
(HTML "
<form method=\"post\"
action=\""#/site/login"\"
>
<label for=\"login_name\"
class=\"hidden\">Account name</label>
<input type=\"text\"
name=\"name\"
id=\"login_name\"
class=\"login_input\"
/>
<label for=\"login_password\"
class=\"hidden\">Password</label>
<input type=\"password\"
name=\"password\"
id=\"login_password\"
class=\"login_input\"
/>
<input type=\"submit\"
name=\"login\"
value=\"login\"
id=\"login_submit\"
/>
<br />
<div id=\"register\">
<a href=\""#/site/register"\">register</a>
</div>
<input type=\"submit\"
name=\"reset-pw\"
value=\"reset password\"
id=\"reset_pw\"
/>
</form>"))
(HTML "
</div>
</div>
</body></html>])
</div>
</body>
</html>"))
(defmacro render-page (title &body body)
`(let* ((*header* *header*)
(*footer* *footer*)
(*title* *title*) ;; in case ,title does setf
(*title* ,title)
(body (with-output-to-string (*html-stream*)
,@body)))
(with-output-to-string (*html-stream*)
(render-header)
(princ body *html-stream*)
(render-footer))))
(let ((article-body (gensym)))
`(let ((*HEADER* *HEADER*)
(*FOOTER* *FOOTER*)
(*TITLE* ,title))
;; title and header might not be known until body is generated
(let ((,article-body
(with-output-to-string (*HTML-output*)
,@body)))
(with-output-to-string (*HTML-output*)
(render-header)
(write-string ,article-body *HTML-output*)
(render-footer))))))
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2011, 2012 Vladimir Sedach <vsedach@common-lisp.net>
......@@ -23,7 +25,10 @@
(let ((page-uri (symbol-name (if (listp page) (car page) page))))
`(progn
(pushnew (list ,page-uri) %defined-uris :test #'equal)
(define-easy-handler (,(if (listp page) (cadr page) page) :uri ,(string-downcase page-uri) :default-request-type ,method) ,parameters
(define-easy-handler (,(if (listp page) (cadr page) page)
:uri ,(string-downcase page-uri)
:default-request-type ,method)
,parameters
,@body))))
(defmacro defpage (page title parameters &body body)
......
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2012 Vladimir Sedach <vsedach@common-lisp.net>
;;; Copyright 2012 Jianshi Huang <jianshi.huang@gmail.com>
......@@ -28,7 +30,8 @@
(defun collect-links (link-type content)
(let (names)
(ppcre:do-register-groups (name) (#?/${link-type}\(([^\)]*)\)/ content)
(ppcre:do-register-groups (name)
(#?/${link-type}\(([^\)]*)\)/ content)
(pushnew (canonicalize name) names :test #'string=))
names))
......@@ -40,56 +43,81 @@
;;; full-text search
(defparameter *common-words*
'("" "a" "also" "an" "and" "are" "as" "at" "be" "but" "by" "can" "for" "from"
"has" "have" "here" "i" "if" "in" "is" "it" "not" "of" "on" "or" "s" "see"
"so" "that" "the" "there" "this" "to" "us" "which" "with" "you"))
(defun words (content)
(let (words)
(dolist (word (ppcre:split "<.*?>|_|\\s|[^\\w]" (string-downcase content)))
(unless (member word *common-words* :test #'string=)
(pushnew (stem:stem word) words :test #'string=)))
words))
(let ((common-words
#("" "a" "also" "an" "and" "are" "as" "at" "be" "but" "by"
"can" "for" "from" "has" "have" "here" "i" "if" "in" "is"
"it" "not" "of" "on" "or" "s" "see" "so" "that" "the"
"there" "this" "to" "us" "which" "with" "you")))
(defun words (content)
(let (words)
(dolist (word (ppcre:split "<.*?>|_|\\s|[^\\w]"
(string-downcase content)))
(unless (find word common-words :test #'string=)
(pushnew (stem:stem word) words :test #'string=)))
words)))
(defun search-articles (phrase)
(let ((words (words phrase)))
(when words
(sort (copy-list (reduce (lambda (&optional a b)
(intersection a b :test #'string=))
(mapcar #'articles-by-search-word words)))
#'< :key (lambda (title)
(let ((title (canonicalize title)))
(loop for word in words
for weight from 0 by 100
thereis (awhen (search word title)
(+ (* it 100) weight (length title)))
finally (return most-positive-fixnum))))))))
(defun paginate-article-summaries (start articles &optional (next-page-uri "?"))
(sort (copy-list
(reduce (lambda (&optional a b)
(intersection a b :test #'string=))
(mapcar #'articles-by-search-word words)))
#'<
:key
(lambda (title)
(let ((title (canonicalize title)))
(loop for word in words
for weight from 0 by 100
thereis (awhen (search word title)
(+ (* it 100) weight (length title)))
finally (return most-positive-fixnum))))))))
(defun paginate-article-summaries
(start articles &optional (next-page-uri "?"))
(let ((page-size 10)
(start (or (parse-integer (or start "0") :junk-allowed t) 0)))
(flet ((page-uri (page# label)
#H[<span><a href="${next-page-uri}&start=${(* page# page-size)}">${label}</a></span>]))
#H[<ol start="${(1+ start)}">]
(loop for i from start below (min (+ start page-size) (length articles))
(start (or (parse-integer (or start "0") :junk-allowed t)
0)))
(flet ((page-uri (page-number label)
(HTML "
<span>
<a href=\""next-page-uri"&start="(* page-number page-size)"\">"
label
"</a>
</span>
")))
(HTML "
<ol start=\""(1+ start)"\">
")
(loop for i from start below (min (+ start page-size)
(length articles))
do (pprint-article-summary-li (elt articles i) "<br />"))
#H[</ol>
<div id="paginator">
<span>Result page:</span>]
(HTML "
</ol>
<div id=\"paginator\">
<span>Result page:</span>
")
(unless (= 0 start)
(page-uri (ceiling (- start page-size) page-size) "&lt;"))
(dotimes (page# (ceiling (length articles) page-size))
(if (= start (* page# page-size))
#H[<span>${(1+ page#)}</span>]
(page-uri page# (1+ page#))))
(dotimes (page-number (ceiling (length articles) page-size))
(if (= start (* page-number page-size))
(HTML "<span>"(1+ page-number)"</span>")
(page-uri page-number (1+ page-number))))
(unless (>= (+ start page-size) (length articles))
(page-uri (ceiling (+ start page-size) page-size) "&gt;"))
#H[</div>])))
(HTML "
</div>
"))))
(defpage /site/search "Search results" (query start)
#H[<h1>Search results</h1>]
(HTML "<h1>Search results</h1>")
(aif (search-articles query)
(paginate-article-summaries start it #U?query={query})
#H[No results found]))
(HTML "No results found")))
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2011, 2012 Vladimir Sedach <vsedach@common-lisp.net>
;;; Copyright 2011, 2012, 2019 Vladimir Sedach <vsedach@common-lisp.net>
;;; Copyright 2012 Goheeca
;;; SPDX-License-Identifier: AGPL-3.0-or-later
......@@ -22,71 +24,86 @@
(in-readtable cliki2)
(sanitize:define-sanitize-mode +links-only+
:elements ("a")
:attributes (("a" . ("href" "class")))
:protocols (("a" . (("href" . (:ftp :http :https :mailto :relative))))))
:elements ("a")
:attributes (("a" . ("href" "class")))
:protocols (("a" . (("href" . (:ftp :http :https
:mailto :relative))))))
(sanitize:define-sanitize-mode +cliki-tags+
:elements ("a" "blockquote" "q" "dd" "dl" "dt" "h1" "h2" "h3" "h4" "h5"
"h6" "hgroup" "pre" "code" "kbd" "samp" "cite" "var" "time"
"figure" "figcaption" "img" "table" "caption" "tbody" "td"
"tfoot" "th" "thead" "tr" "col" "colgroup" "ul" "ol" "li" "b"
"em" "i" "small" "big" "tt" "strike" "strong" "dfn" "s" "sub"
"sup" "u" "abbr" "ruby" "rp" "rt" "bdo" "mark" "br" "hr")
:attributes ((:all . ("dir" "lang" "title" "class"))
("a" . ("href"))
("abbr" . ("title"))
("bdo" . ("dir"))
("blockquote" . ("cite"))
("col" . ("span" "width" "align" "valign"))
("colgroup" . ("span" "width" "align" "valign"))
("img" . ("align" "alt" "height" "src" "width"))
("ol" . ("start" "reversed" "type"))
("ul" . ("type"))
("code" . ("lang"))
("q" . ("cite"))
("table" . ("summary" "width"))
("td" . ("abbr" "axis" "colspan" "rowspan" "width"))
("th" . ("abbr" "axis" "colspan" "rowspan" "scope" "width")))
:protocols (("a" . (("href" . (:ftp :http :https :mailto :relative))))
("blockquote" . (("cite" . (:http :https :relative))))
("img" . (("src" . (:http :https :relative))))
("q" . (("cite" . (:http :https :relative))))))
:elements
("a" "blockquote" "q" "dd" "dl" "dt" "h1" "h2" "h3" "h4" "h5"
"h6" "hgroup" "pre" "code" "kbd" "samp" "cite" "var" "time"
"figure" "figcaption" "img" "table" "caption" "tbody" "td"
"tfoot" "th" "thead" "tr" "col" "colgroup" "ul" "ol" "li" "b"
"em" "i" "small" "big" "tt" "strike" "strong" "dfn" "s" "sub"
"sup" "u" "abbr" "ruby" "rp" "rt" "bdo" "mark" "br" "hr")
:attributes
((:all . ("dir" "lang" "title" "class"))
("a" . ("href"))
("abbr" . ("title"))
("bdo" . ("dir"))
("blockquote" . ("cite"))
("col" . ("span" "width" "align" "valign"))
("colgroup" . ("span" "width" "align" "valign"))
("img" . ("align" "alt" "height" "src" "width"))
("ol" . ("start" "reversed" "type"))
("ul" . ("type"))
("code" . ("lang"))
("q" . ("cite"))
("table" . ("summary" "width"))
("td" . ("abbr" "axis" "colspan" "rowspan" "width"))
("th" . ("abbr" "axis" "colspan" "rowspan" "scope"
"width")))
:protocols
(("a" . (("href" . (:ftp :http :https :mailto :relative))))
("blockquote" . (("cite" . (:http :https :relative))))
("img" . (("src" . (:http :https :relative))))
("q" . (("cite" . (:http :https :relative))))))
(defun generate-html-from-markup (markup)
#H[<div id="article">]
(HTML "
<div id=\"article\">
")
(let ((start 0)
tag-start
close-tag)
(labels ((find-tag (tag start)
(search tag markup :start2 start :test #'string-equal))
(find-next-tag (start)
(let ((next-pre (find-tag "<pre>" start))
(next-code (find-tag "<code" start))
min)
(when next-pre
(setf close-tag "</pre>"
min next-pre))
(when next-code
(unless (and next-pre (< next-pre next-code))
(setf close-tag "</code>"
min next-code)))
min)))
(loop while (setf tag-start (find-next-tag start))
do (write-string (parse-markup-fragment markup start tag-start)
*html-stream*)
(setf start (+ (length close-tag)
(or (find-tag close-tag tag-start)
(return))))
(write-string (funcall (if (equal close-tag "</pre>")
#'escape-pre-block
#'markup-code)
markup tag-start start)
*html-stream*)))
(write-string (parse-markup-fragment markup start (length markup))
*html-stream*))
#H[</div>])
(labels
((find-tag (tag start)
(search tag markup :start2 start :test #'string-equal))
(find-next-tag (start)
(let ((next-pre (find-tag "<pre>" start))
(next-code (find-tag "<code" start))
min)
(when next-pre
(setf close-tag "</pre>"
min next-pre))
(when next-code
(unless (and next-pre (< next-pre next-code))
(setf close-tag "</code>"
min next-code)))
min)))
(do () ((not (setf tag-start (find-next-tag start))))
(write-string (parse-markup-fragment markup start tag-start)
*HTML-output*)
(setf start (+ (length close-tag)
(or (find-tag close-tag tag-start)
(return))))
(write-string (funcall (if (equal close-tag "</pre>")
#'escape-pre-block
#'markup-code)
markup tag-start start)
*HTML-output*)))
(write-string
(parse-markup-fragment markup start (length markup))
*HTML-output*))
(HTML "
</div>
"))
(defun parse-markup-fragment (markup start end)
(ppcre:regex-replace-all
......@@ -105,7 +122,10 @@
"<(?:PRE|pre)>((?:.|\\n)*?)</(?:PRE|pre)>" markup
(lambda (match preformatted)
(declare (ignore match))
#?[<pre>${(escape-for-html preformatted)}</pre>])
(concatenate 'string
"<pre>"
(escape-for-html preformatted)
"</pre>"))
:simple-calls t :start start :end end))
(defun escape-parens-in-href-links (markup start end)
......@@ -128,7 +148,7 @@
markup
(lambda (match prefix title)
(declare (ignore match))
(with-output-to-string (*html-stream*)
(with-output-to-string (*HTML-output*)
(funcall (cdr
(assoc prefix
'(("_" . pprint-article-underscore-link)
......@@ -151,23 +171,38 @@
(subseq c 0 (ppcre:scan "\\.(?:\\s|$)|\\n|$" c))))
(defun pprint-article-summary-li (article-title separator)
#H[<li>] (pprint-article-link article-title) #H[ ${separator}
${(sanitize:clean
(with-output-to-string (*html-stream*)
(generate-html-from-markup (article-description article-title)))
+links-only+)}
</li>])
(HTML "
<li>
")
(pprint-article-link article-title)
(HTML " "separator" "
(sanitize:clean
(with-output-to-string (*HTML-output*)
(generate-html-from-markup
(article-description article-title)))
+links-only+)
"
</li>
"))
(defun format-topic-list (topic) ;; /(
#H[<ul>] (dolist (article (articles-by-topic topic))
(pprint-article-summary-li article "-"))
#H[</ul>])
(HTML "
<ul>
")
(dolist (article (articles-by-topic topic))
(pprint-article-summary-li article "-"))
(HTML "
</ul>
"))
(defun format-hyperspec-link (symbol) ;; _H(
#H[<a href="${(clhs-lookup:spec-lookup symbol)}" class="hyperspec">${symbol}</a>])
(HTML "<a href=\""(clhs-lookup:spec-lookup symbol)"\"
class=\"hyperspec\">"symbol"</a>"))
(defun format-package-link (link) ;; _P(
#H[<a href="${link}">ASDF-install package (obsolete) ${link}</a>])
(HTML "<a href=\""link"\">ASDF-install package (obsolete) "
link
"</a>"))
(let ((supported-langs (sort (mapcar (lambda (x)
(symbol-name (car x)))
......@@ -178,9 +213,10 @@
"<(?:CODE|code)(.*?)?>((?:.|\\n)*?)</(?:CODE|code)>" markup
(lambda (match maybe-lang code)
(declare (ignore match))
(let ((lang (loop for lang in supported-langs
when (search lang maybe-lang :test #'char-equal)
return (find-symbol lang :keyword))))
(let ((lang
(dolist (lang supported-langs)
(when (search lang maybe-lang :test #'char-equal)
(return (find-symbol lang :keyword))))))
(if lang
(let ((colorize::*css-background-class* "nonparen"))
#?[<div class="code">${(colorize::html-colorization lang code)}</div>])
......
;;;; -*- encoding:utf-8 -*-
(in-package #:cl)
(defpackage #:cliki2
......
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2011 Vladimir Sedach <vsedach@common-lisp.net>
;;; Copyright 2011, 2019 Vladimir Sedach <vsedach@common-lisp.net>
;;; SPDX-License-Identifier: AGPL-3.0-or-later
......@@ -22,7 +24,7 @@
(defparameter %defined-uris '(("/")))
(defparameter %referenced-uris ())
(defvar *html-stream* *standard-output*)
(defvar *HTML-output* *standard-output*)
(defreadtable cliki2
(:merge :standard uri-template:uri-template)
......@@ -30,10 +32,6 @@
(:dispatch-macro-char
#\# #\?
#'cl-interpol::interpol-reader)
(:dispatch-macro-char
#\# #\H
(lambda (&rest args)
`(princ ,(apply #'cl-interpol::interpol-reader args) *html-stream*)))
(:dispatch-macro-char
#\# #\/
(lambda (stream subchar arg)
......
;;;; -*- encoding:utf-8 -*-
;;; Copyright 2011 Andrey Moskvitin <archimag@gmail.com>
;;; Copyright 2011, 2012 Vladimir Sedach <vsedach@common-lisp.net>
;;; Copyright 2011, 2012, 2019 Vladimir Sedach <vsedach@common-lisp.net>
;;; SPDX-License-Identifier: AGPL-3.0-or-later
......@@ -21,61 +23,95 @@
(in-readtable cliki2)
(defun find-previous-revision (revision)
(cadr (member revision (revisions
(find-article (parent-title revision) :error t)))))
(cadr (member revision
(revisions
(find-article (parent-title revision) :error t)))))
(defun %render-revision-summary (revision)
(pprint-revision-link revision)
#H[ <a class="internal" href="${ (article-link (parent-title revision)) }">${ (escape-for-html (parent-title revision)) }</a>
- ${ (escape-for-html (summary revision)) } ${ (account-link (author-name revision)) } ]
(HTML " <a class=\"internal\" href=\""
(article-link (parent-title revision))
"\">"(escape-for-html (parent-title revision))
"</a> - "
(escape-for-html (summary revision))" "
(account-link (author-name revision))" ")
(awhen (find-previous-revision revision)
(output-compare-link it revision "diff")))
(defun render-revision-summary (revision)
#H[<li>] (%render-revision-summary revision) #H[</li>])
(HTML "
<li>
")
(%render-revision-summary revision)
(HTML "
</li>
"))
(defpage /site/recent-changes "Recent Changes" ()
(setf *header* #?[<link rel="alternate" type="application/atom+xml" title="recent changes" href="$(#/site/feed/recent-changes.atom)">])
#H[<h1>Recent Changes</h1>
<a class="internal" href="$(#/site/feed/recent-changes.atom)">ATOM feed</a>
<ul>] (map nil #'render-revision-summary (get-recent-changes)) #H[</ul>])
(setf *HEADER* #?[<link rel="alternate" type="application/atom+xml" title="recent changes" href="$(#/site/feed/recent-changes.atom)">])
(HTML "
<h1>Recent Changes</h1>
<a class=\"internal\"
href=\""#/site/feed/recent-changes.atom"\">ATOM feed</a>
</