support for deleting post comments

5 files changed, 43 insertions, 8 deletions

diff --git a/tekuti/comment.scm b/tekuti/comment.scm
index 54229f0..8d3b018 100644
--- a/tekuti/comment.scm
+++ b/tekuti/comment.scm
@@ -29,12 +29,14 @@
   #:use-module (tekuti git)
   #:use-module (tekuti util)
   #:use-module (tekuti filters)
+  #:use-module (tekuti post)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (sxml transform)
   #:use-module (tekuti match-bind)
   #:export (blob->comment comment-sxml-content comment-timestamp
-            comment-readable-date bad-new-comment-post? make-new-comment))
+            comment-readable-date bad-new-comment-post?
+            make-new-comment delete-comment))
 
 (define *comment-spec*
   `((timestamp . ,string->number)))
@@ -146,3 +148,15 @@
                                        (list sha1 sha1 'blob))
                           master message #f))
        5))))
+
+(define (delete-comment post id)
+  (let ((key (post-key post))
+        (message (format #f "~a on \"~a\"" "comment deleted" (post-title post))))
+    (git-update-ref "refs/heads/master"
+                  (lambda (master)
+                    (git-commit-tree (munge-tree1 master
+                                                  'delete
+                                                  `(,key "comments")
+                                                  `(,id))
+                                     master message #f))
+                  5)))
diff --git a/tekuti/page-helpers.scm b/tekuti/page-helpers.scm
index 7e7be48..5d2b7cc 100644
--- a/tekuti/page-helpers.scm
+++ b/tekuti/page-helpers.scm
@@ -192,6 +192,10 @@
                      (action ,(relurl `("admin" "delete-post" ,(post-key post)))))
                   " "
                   (input (@ (type "submit") (name "delete") (value "delete"))))
+            ,@(let ((l (comments-sxml-content-edit post)))
+                (if (null? l) l
+                    `((h2 "comments")
+                      (ol (@ (class "commentlist")) ,@l))))
             (h2 "preview")
             ,(show-post post #f))
           '())))
@@ -238,6 +242,18 @@
     (p (input (@ (name "submit") (type "submit") (id "submit") (tabindex "5")
                  (value "Submit Comment"))))))
 
+(define (comments-sxml-content-edit post)
+  (map 
+   (lambda (comment)
+     (let ((id (assq-ref comment 'key)))
+       `(,(comment-sxml-content comment)
+         (form (@ (method "POST")
+                   (action ,(relurl `("admin" "delete-comment"
+                                      ,(post-key post) ,id))))
+                (input (@ (type "submit") (name "delete") (value "delete"))))
+         (br))))
+   (post-comments post)))
+  
 (define (post-sxml-comments post)
   (let ((comments (post-comments post))
         (comments-open? (post-comments-open? post)))
diff --git a/tekuti/page.scm b/tekuti/page.scm
index b2fa305..6844a95 100644
--- a/tekuti/page.scm
+++ b/tekuti/page.scm
@@ -42,6 +42,7 @@
             page-admin-new-post
             page-admin-modify-post 
             page-admin-delete-post 
+            page-admin-delete-comment
             page-admin-changes 
             page-admin-change
             page-admin-revert-change
@@ -133,6 +134,14 @@
      (delete-post key)
      (respond `((p "redirecting...")) #:redirect (relurl `("admin"))))))
      
+(define (page-admin-delete-comment request body index key comment-id)
+  (with-authentication
+   request
+   (lambda ()
+     (let ((post (post-from-key (assq-ref index 'master) key #t)))
+       (delete-comment post comment-id)
+       (respond `((p "redirecting...")) #:redirect (admin-post-url post))))))
+     
 (define (page-admin-changes request body index) 
   (with-authentication
    request
diff --git a/tekuti/post.scm b/tekuti/post.scm
index 2e5abbc..dd54f93 100644
--- a/tekuti/post.scm
+++ b/tekuti/post.scm
@@ -202,16 +202,11 @@
   (munge-post old-key (parse-post-data post-data)))
 
 (define (delete-post key)
-  (define (maybe-delete ops)
-      (if (and old-key (not (equal? old-key key)))
-          (cons  ops)
-          ops))
-  (let* ((ops `((delete () (,key))))
-         (post (post-from-key "refs/heads/master" key))
+  (let* ((post (post-from-key "refs/heads/master" key))
          (message (format #f "~a: \"~a\"" "post deleted" (post-title post))))
     (git-update-ref "refs/heads/master"
                   (lambda (master)
-                    (git-commit-tree (munge-tree master ops)
+                    (git-commit-tree (munge-tree1 master 'delete '() `(,key))
                                      master message #f))
                   5)))
 
diff --git a/tekuti/web.scm b/tekuti/web.scm
index d5d9fc9..fcd227d 100644
--- a/tekuti/web.scm
+++ b/tekuti/web.scm
@@ -44,6 +44,7 @@
    ;; web browsers don't handle that
    ((POST admin delete-post post-key!) page-admin-delete-post)
    ((POST admin modify-post post-key!) page-admin-modify-post)
+   ((POST admin delete-comment post-key! comment-id!) page-admin-delete-comment)
    ((GET admin changes) page-admin-changes)
    ((GET admin changes sha1!) page-admin-change)
    ((POST admin revert-change sha1!) page-admin-revert-change)