Permalink
Browse files

Added article deletion/undeletion

  • Loading branch information...
1 parent 34d2767 commit e20b495299149707625044c0303d600c1a14b57f @vsedach committed Nov 27, 2011
View
@@ -1,4 +1,4 @@
-* article deletion (404 on subsequent access but still have history)
+* Scrub content before indexing
* create article button
* fix BS with clhs-lookup pathnames and Symbol-Table.text
* make sure ASDF-Install still works
@@ -22,7 +22,32 @@
do (setf content (fixup-tag regex content action)))
content))
-(defun load-old-articles (old-article-dir &key verbose)
+(defun maybe-delete-article (article args)
+ (apply #'cliki2::delete-article article args))
+
+(defun import-revision (article content args)
+ (apply #'cliki2::add-revision article "import from CLiki" content args))
+
+(defun import-revisions (account article revision-paths)
+ (let ((timestamp-skew 0))
+ (dolist (path revision-paths)
+ (let* ((date (+ (incf timestamp-skew) (file-write-date path)))
+ (unix-date (local-time:timestamp-to-unix
+ (local-time:universal-to-timestamp date)))
+ (content (convert-article-revision (read-file path)))
+ (args (list :author account
+ :author-ip "0.0.0.0"
+ :date date))
+ (revision
+ (or (when (and (eq path (car (last revision-paths)))
+ (search "*(delete this page)"
+ content :test #'char-equal))
+ (maybe-delete-article article args))
+ (import-revision article content args))))
+ (sb-posix:utimes (cliki2::revision-path revision)
+ unix-date unix-date)))))
+
+(defun load-old-articles (old-article-dir)
"WARNING: This WILL blow away your old store."
(close-store)
@@ -33,11 +58,12 @@
(open-store (merge-pathnames "store/" cliki2::*datadir*))
- (let ((old-articles (make-hash-table :test 'equalp))) ;; equalp is case insensitive
+ (let ((old-articles (make-hash-table :test 'equalp))) ;; case insensitive
(dolist (file (cl-fad:list-directory old-article-dir))
- (let ((file-name (hunchentoot:url-decode
- (substitute #\% #\= (pathname-name file))
- hunchentoot::+latin-1+)))
+ (let ((file-name (cliki2::cut-whitespace
+ (hunchentoot:url-decode
+ (substitute #\% #\= (pathname-name file))
+ hunchentoot::+latin-1+))))
(setf (gethash file-name old-articles)
(merge 'list
(list file)
@@ -46,40 +72,20 @@
:key (lambda (x)
(parse-integer (or (pathname-type x) "0")
:junk-allowed t))))))
- ;; discard deleted pages
- (loop for article being the hash-key of old-articles do
- (when (search "*(delete this page)"
- (read-file (car (last (gethash article old-articles))))
- :test #'char-equal)
- (remhash article old-articles)))
+
;; import into store
(let ((cliki-import-user (make-instance 'cliki2::account
:name "CLiki-importer"
:email "noreply@cliki.net"
:password-salt "000000"
:password-digest "nohash")))
- (loop for i from 0
- for article-title being the hash-key of old-articles
- for files being the hash-value of old-articles do
- (let ((article (make-instance 'cliki2::article :title article-title))
- (timestamp-skew 0)) ;; some revisions have identical timestamps
- (when verbose
- (format t "~A%; Convert ~A~%"
- (floor (* (/ i (hash-table-count old-articles)) 100))
- article-title))
- (dolist (file files)
- (let* ((date (+ (incf timestamp-skew) (file-write-date file)))
- (revision (cliki2::add-revision
- article
- "import from CLiki"
- (convert-article-revision (read-file file))
- :author cliki-import-user
- :author-ip "0.0.0.0"
- :date date)))
- (let ((unix-time (local-time:timestamp-to-unix
- (local-time:universal-to-timestamp date))))
- (sb-posix:utimes (cliki2::revision-path revision)
- unix-time unix-time))))))))
+ (loop for article-title being the hash-key of old-articles
+ for revision-paths being the hash-value of old-articles do
+ (import-revisions
+ cliki-import-user
+ (make-instance 'cliki2::article :title article-title)
+ revision-paths))))
+
(cliki2::init-recent-revisions)
(snapshot))
View
@@ -32,5 +32,8 @@
(:file "diff")
(:file "search")
(:file "recent-changes")
+ (:file "deleted-articles")
+ (:file "history")
(:file "tools")
+ (:file "dispatcher")
(:file "start")))))
View
@@ -1,16 +1,17 @@
(in-package #:cliki2)
(in-readtable cliki2)
-;;; delete article (only logged-in users can delete, view, and undelete deleted articles)
-
(defun cut-whitespace (str)
(string-trim #(#\Space #\Tab #\Newline #\Return)
(ppcre:regex-replace-all "\\s+" str " ")))
;;; article categories
+(defun canonicalize (title)
+ (string-downcase (cut-whitespace title)))
+
(defun category-keyword (category-title)
- (intern (string-upcase (cut-whitespace category-title)) '#:cliki2.categories))
+ (intern (canonicalize category-title) '#:cliki2.categories))
(defun content-categories (content)
(let (categories)
@@ -42,19 +43,19 @@
canonical-title (string-downcase title))))
(defun find-article (title)
- (article-with-canonical-title (string-downcase (cut-whitespace title))))
+ (article-with-canonical-title (canonicalize title)))
(defun latest-revision (article)
(car (revisions article)))
(defun article-description (article)
(ppcre:scan-to-strings ".*?(\\.(\\s|$)|\\n|$)" (cached-content article)))
-(defmethod link-to ((article article))
+(defmethod link-to ((article store-object))
(link-to (canonical-title article)))
(defmethod link-to ((article-titled string))
- #?[/${(uri-encode (string-downcase (cut-whitespace article-titled)))}])
+ #?[/${(uri-encode (canonicalize article-titled))}])
(defun %print-article-link (title class)
#H[<a href="${(link-to title)}" class="${class}">${title}</a>])
@@ -92,8 +93,9 @@
(author (or *account*
(get-anonymous-account (real-remote-addr))))
(author-ip (real-remote-addr))
- (date (get-universal-time)))
- (let ((new-revision (make-instance 'revision
+ (date (get-universal-time))
+ (revision-type 'revision))
+ (let ((new-revision (make-instance revision-type
:article article
:author author
:author-ip author-ip
@@ -125,12 +127,17 @@
(loop for category in it for divider = nil then t do
(when divider #H" | ") (pprint-category-link category))
#H[</div>])
- (setf *footer*
- (let ((title (title (article revision))))
- #?[
-<li><a href="${(link-to (article revision))}">Current version</a></li>
-<li><a href="$(#/site/history?title={title})">History</a></li>
-<li>${(link-to-edit revision "Edit")}</li>])))
+ (setf
+ *footer*
+ (let ((title (title (article revision))))
+ (with-output-to-string (*html-stream*)
+ #H[<li><a href="${(link-to (article revision))}">Current version</a></li>
+ <li><a href="$(#/site/history?title={title})">History</a></li>]
+ (unless (youre-banned?)
+ #H[<li>${(link-to-edit revision "Edit")}</li>]
+ (when *account*
+ #H[<li><form method="post" action="$(#/site/delete?title={title})">
+ <input class="del" type="submit" value="Delete" /></form></li>]))))))
(defun find-revision (string-id)
(let ((revision (store-object-with-id (parse-integer string-id))))
@@ -146,90 +153,12 @@
(defun pprint-revision-link (revision)
#H[<a class="internal" href="${(link-to revision)}">${(rfc-1123-date (date revision))}</a>])
-;;; article history
-
-(defpage /site/history () (title)
- (awhen (find-article title)
- (setf *title* #?'History of article: "${title}"')
- #H[<h1>History of article ] (pprint-article-link title) #H[</h1>
- <form method="post" action="$(#/site/do-compare-revisions)">
- <input type="submit" value="Compare selected versions" />
- <table id="pagehistory">]
-
- (loop for rhead on (revisions it)
- for revision = (car rhead)
- for author = (author revision)
- for first = t then nil do
- (flet ((radio (x)
- #H[<td><input type="radio" name="${x}" value="${(store-object-id revision)}" /></td>]))
- #H[<tr><td>]
- (awhen (cadr rhead)
- #H[(<a href="$(#/site/compare-revisions?old={(store-object-id it)}&diff={(store-object-id revision)})">prev</a>)])
- #H[</td>]
- (radio "old") (radio "diff")
- #H[<td>] (pprint-revision-link revision)
- #H[ ${(format-account-link author)} (<em>${(summary revision)}</em>) ]
- (when first
- #H[(<a href="$(#/site/undo?r={(store-object-id revision)})">undo</a>)])
- #H[</td></tr>]))
-
- #H[</table>
- <input type="submit" value="Compare selected versions" />
- </form>]
-
- (setf *footer* #?[<li><a href="${(link-to it)}">Current version</a></li>])))
-
-(defun check-banned ()
- (when (youre-banned?) #H[Your account/IP is banned from editing]))
-
-(defpage /site/undo () (r)
- (let* ((revision (find-revision r))
- (article (article revision)))
- (cond ((check-banned))
- ((eq revision (latest-revision article))
- (add-revision article
- #?"undid last revision by ${(name (author revision))}"
- (revision-content (second (revisions article))))
- (redirect (link-to article)))
- (t #H[Can't undo this revision because it is not the latest.
- <a href="$(#/site/history?title={(title article)})">Go back to history page</a>.]))))
-
-;;; diff
-
-(defhandler /site/do-compare-revisions (old diff)
- #/site/compare-revisions?old={old}&diff={diff})
-
-(defpage /site/compare-revisions () (old diff)
- (let ((oldr (find-revision old))
- (diffr (find-revision diff)))
- (when (> (date oldr) (date diffr))
- (rotatef oldr diffr))
- (setf *title* (title (article oldr)))
- #H[<h1>${(title (article oldr))}</h1>
- <table class="diff">
- <colgroup>
- <col class="diff-marker"> <col class="diff-content">
- <col class="diff-marker"> <col class="diff-content">
- </colgroup>
- <tbody>
- <tr>
- <th colspan="2"> Version ] (pprint-revision-link oldr)
- #H[ (${(link-to-edit oldr "edit")})</th>
- <th colspan="2"> Version ] (pprint-revision-link diffr)
- #H[ (${(link-to-edit diffr "edit")})]
- (when (eq diffr (latest-revision (article diffr)))
- #H[ (<a href="$(#/site/undo?r={(store-object-id diffr)})">undo</a>)])
- #H[</th>
- </tr>
- ${(diff:format-diff-string 'wiki-diff (revision-path oldr) (revision-path diffr))}
- </tbody>
- </table>]))
-
;;; edit article
(defpage /site/edit-article () (title content summary from-revision save)
(let ((maybe-article (find-article title)))
(cond ((check-banned))
+ ((find-deleted-article title) (redirect (link-to title)))
(save (add-revision maybe-article summary content)
(redirect (link-to maybe-article)))
(t (setf *title* #?"Editing ${title}")
@@ -257,22 +186,3 @@
(when content
#H[<h1>Article preview:</h1>]
(generate-html-from-markup content))))))
-
-;;; article dispatcher
-
-(defun guess-article-name ()
- (uri-decode (subseq (script-name*) 1)))
-
-(defun render-article (article)
- (let ((*header* #?[<link rel="alternate" type="application/rss+xml" title="edits"
- href="$(#/site/article-feed/rss.xml?title={(title article)})">]))
- (render-page (title article)
- (render-revision (latest-revision article) (cached-content article)))))
-
-(defun article-dispatcher (request)
- (declare (ignore request))
- (awhen (find-article (guess-article-name))
- (lambda () (render-article it))))
-
-(define-easy-handler (root :uri "/") ()
- (render-article (find-article "index")))
@@ -0,0 +1,80 @@
+(in-package #:cliki2)
+(in-readtable cliki2)
+
+(defclass deleted-article (store-object)
+ ((title :initarg :title
+ :reader title)
+ (canonical-title :initarg :canonical-title
+ :reader canonical-title
+ :index-type string-unique-index
+ :index-reader deleted-article-with-title)
+ (revisions :initarg :revisions
+ :reader revisions))
+ (:metaclass persistent-class))
+
+(defun find-deleted-article (title)
+ (deleted-article-with-title (canonicalize title)))
+
+(defun find-article-any (title)
+ (or (find-article title) (find-deleted-article title)))
+
+(defmethod pprint-article-summary-li ((article deleted-article) separator)
+ #H[<li>] (pprint-article-link (title article)) #H[ ${separator} </li>])
+
+(defun %move-revisions (old-article new-article)
+ (dolist (r (revisions old-article))
+ (setf (slot-value r 'article) new-article)))
+
+(defclass revision-undelete (revision) ()
+ (:metaclass persistent-class))
+
+(deftransaction tx-delete-article (article)
+ (let ((deleted (make-instance 'deleted-article
+ :title (title article)
+ :canonical-title (canonical-title article)
+ :revisions (revisions article))))
+ (%move-revisions article deleted)))
+
+(defun delete-article (article &rest args)
+ (prog1 (apply #'add-revision article "Deleted article" "" args)
+ (tx-delete-article article)
+ (delete-object article)))
+
+(deftransaction tx-undelete-article (deleted)
+ (let ((article (make-instance 'article :title (title deleted))))
+ (setf (slot-value article 'revisions) (revisions deleted))
+ (%move-revisions deleted article)
+ article))
+
+(defun undelete-article (deleted)
+ (let ((article (tx-undelete-article deleted)))
+ (add-revision article "Undeleted article"
+ (revision-content (second (revisions article)))
+ :revision-type 'revision-undelete)
+ (delete-object deleted)
+ article))
+
+(defhandler /site/delete (title)
+ (awhen (and (not (youre-banned?))
+ (not (find-deleted-article title))
+ (find-article title))
+ (delete-article it))
+ (link-to title))
+
+(deftransaction tx-permadelete (deleted-article)
+ (dolist (r (revisions deleted-article))
+ (setf *recent-revisions* (remove r *recent-revisions*))
+ (delete-object r)))
+
+(defhandler /site/permadelete (title)
+ (awhen (and (not (youre-banned?))
+ (account-is? *account* :moderator :administrator)
+ (find-deleted-article title))
+ (tx-permadelete it)
+ (delete-object it))
+ #/)
+
+(defhandler /site/undelete (title)
+ (awhen (and (not (youre-banned?)) (find-deleted-article title))
+ (undelete-article it))
+ (link-to title))
Oops, something went wrong.

0 comments on commit e20b495

Please sign in to comment.