various fixes, new post support

* tekuti/comment.scm (make-new-comment): Better commit log for comments.

* tekuti/git.scm (munge-tree): Fix when creating multiple files in a new
  directory.

* tekuti/page-helpers.scm (with-authentication): Resurrect, this got lost
  somehow, in that past time place.
  (post-editing-form): Frobate a bit.
  (admin-post-link): Fix.

* tekuti/page.scm (page-admin): Frobate.
  (page-admin-post): Fix for recent change in post-from-key.
  (page-admin-new-post): Sortof works, needs some fixage.

* tekuti/post.scm (make-new-post): Implement, yay

* tekuti/util.scm (timestamp->date): New function

* tekuti/web.scm (*status-names*): add 303

tekuti/comment.scm

@@ -128,7 +128,9 @@
                     (author_email . ,email)
                     (author_url . ,url)))
                  (display "\n")
-                 (display content))))
+                 (display content)))
+          (message (format #f "comment on \"~a\" by ~a" (post-title post)
+                           author)))
       (git-update-ref
        "refs/heads/master"
        (lambda (master)
@@ -137,5 +139,5 @@
                                          . (,sha1 ,sha1 blob)))
                                       '()
                                       '())
-                          master "new comment" #f))
+                          master message #f))
        5))))

tekuti/git.scm

@@ -31,7 +31,8 @@
   #:use-module (tekuti config)
   #:use-module (scheme kwargs)
   #:use-module (match-bind)
-  #:use-module ((srfi srfi-1) #:select (filter-map partition))
+  #:use-module ((srfi srfi-1) #:select (filter-map partition
+                                        delete-duplicates))
   #:use-module (srfi srfi-11) ; let-values
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -235,10 +236,11 @@
                                (filter-map level-down dchange))
                    'tree)))
           (else dent)))
-       (append (filter-map (lambda (x)
+       (append (delete-duplicates
-                             (and (not (assoc (caar x) dents))
+                (filter-map (lambda (x)
-                                  (list (caar x) #f 'tree)))
+                              (and (not (assoc (caar x) dents))
-                           dadd)
+                                   (list (caar x) #f 'tree)))
+                            dadd))
                dents))))))
     
 (define (parse-commit commit)

tekuti/page-helpers.scm

@@ -39,7 +39,7 @@
             post-editing-form
             sidebar-ul main-sidebar tag-cloud
             post-link admin-post-link
-            show-post
+            show-post with-authentication
             atom-header atom-entry))
 
 (define (relurl . paths)
@@ -61,13 +61,26 @@
                                  (string-append "admin/modify-post/"
                                                 (url:encode (post-key post)))
                                  "admin/new-post"))))
-         (p "title: "
+         (p (input (@ (name "title") (type "text")
-            (input (@ (name "title") (type "text")
+                      (value ,(if post (post-title post) ""))))
-                      (value ,(if post (post-title post) "")))))
+            (label (@ (for "title")) " <- title"))
-         (div (textarea (@ (name "body") (rows "20") (cols "80"))
+         (p (input (@ (name "tags") (type "text")
+                      (value ,(if post
+                                  (string-join (post-tags post) ", ")
+                                  ""))))
+            (label (@ (for "tags")) " <- tags, comma-separated"))
+         (p (input (@ (name "date") (type "text")
+                      (value ,(if (and=> post post-published?)
+                                  (timestamp->rfc822-date (post-timestamp post))
+                                  ""))))
+            (label (@ (for "date")) " <- date"))
+         (div (textarea (@ (name "body") (rows "20") (cols "60"))
                         ,(if post (post-raw-content post) "")))
-         (input (@ (type "submit")
+         (input (@ (type "submit") (name "status")
-                   (value ,(if post "edit post" "new post"))))))
+                   (value "publish")))
+         " "
+         (input (@ (type "submit") (name "status")
+                   (value "draft")))))
 
 (define (sidebar-ul body)
   `(div (@ (id "menu"))
@@ -76,7 +89,7 @@
 ;; double-encoding is a hack to trick apache
 (define (admin-post-link post)
   (rellink (string-append "admin/posts/" (url:encode (post-key post)))
-           (post-title 'title)))
+           (post-title post)))
 
 (define (post-url post . tail)
   (apply relurl "archives/" (url:decode (post-key post)) tail))
@@ -185,6 +198,15 @@
      (li (h2 "tags " ,(rellink "tags/" ">>"))
          ,(tag-cloud index)))))
 
+(define (with-authentication request thunk)
+  (if (request-authenticated? request)
+      (thunk)
+      (rcons* (rpush 'output-headers
+                     '("WWW-Authenticate" . "Basic realm=\"Tekuti\"")
+                     request)
+              'status 401
+              'body `((p "Authentication required, yo")))))
+
 (define (atom-header server-name last-modified)
   (define (relurl tail)
     (string-append "http://" server-name *public-url-base* tail))

tekuti/page.scm

@@ -77,8 +77,8 @@
              (assq-ref index 'posts)
              n))
      (rcons* request
-             'body `(,(sidebar-ul `((li (h2 ,(rellink "admin/posts" "posts"))
+             'body `(,(sidebar-ul `((li (h2 "posts " ,(rellink "admin/posts" ">>"))
-                                        (ul ,@(post-links 10)))
+                                        (ul ,@(post-links 5)))
                                     (li (h2 "recent comments")
                                         (p "ain't got none"))))
                      (h2 "new post")
@@ -100,7 +100,7 @@
   (with-authentication
    request
    (lambda ()
-     (let ((post (post-from-key (assq-ref index 'master) key)))
+     (let ((post (post-from-key (assq-ref index 'master) key #t)))
        (rcons* request
                'body `((h1 ,(post-title post))
                        ,(post-editing-form post)))))))
@@ -109,20 +109,22 @@
   (with-authentication
    request
    (lambda ()
-     (let ((form-data (request-form-data request)))
+     (let ((post (make-new-post (request-form-data request))))
        (rcons* request
                'status 201              ; created
-               'output-headers (acons "Location" *public-url-base*
+               ;; perhaps set Location:
-                                      (rref request 'output-headers '()))
+               'body `((h1 ,(post-title post))
-               'body `((h1 "Created")
+                       ,(post-editing-form post)))))))
-                       (p "Created new post: " ,(assoc-ref form-data "title"))
-                       (pre ,(assoc-ref form-data "body"))))))))
 
 (define (page-admin-modify-post request index key)
   (with-authentication
    request
    (lambda ()
-     (not-implemented request index))))
+     (let ((post (modify-post key (request-form-data request))))
+       (rcons* 'status 303
+               'body `((h1 ,(post-title post))
+                       ,(post-editing-form post)))))))
+     
 (define page-delete-comment not-implemented)
 (define page-delete-post not-implemented)
 

tekuti/post.scm

@@ -40,8 +40,11 @@
             post-tags post-timestamp post-key post-published?
             post-comments-open? post-comments
             post-sxml-content post-readable-date post-n-comments
+            post-raw-content
             post-title
 
+            make-new-post
+
             all-published-posts
 
             reindex-posts))
@@ -124,6 +127,57 @@
 (define (post-n-comments post)
   (length (git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f)))
 
+(define (string-split/trimming string delimiter)
+  (map string-trim-both (string-split string delimiter)))
+
+(define space-to-dash (s///g " +" "-"))
+(define remove-extraneous (s///g "[^a-z-]+" ""))
+
+(define (title->name title)
+  (remove-extraneous (space-to-dash (string-downcase title))))
+
+;; some verification necessary...
+(define (make-new-post post-data)
+  (define (make-post-key date name)
+    (url:encode (string-append (date->string date "~Y/~m/~d/")
+                               (url:encode name))))
+  (let ((title (assoc-ref post-data "title"))
+        (body (assoc-ref post-data "body"))
+        (tags (assoc-ref post-data "tags"))
+        (date (assoc-ref post-data "date"))
+        (status (assoc-ref post-data "status")))
+    (let ((timestamp (if (string-null? date)
+                         (time-second (current-time))
+                         (rfc822-date->timestamp date))))
+      (let ((metadata (with-output-to-blob
+                       (for-each
+                        (lambda (pair)
+                          (format #t "~a: ~a\n" (car pair) (cdr pair)))
+                        `((timestamp . ,timestamp)
+                          (tags . ,tags)
+                          (status . ,status)
+                          (title . ,title)
+                          (name . ,(title->name title))))))
+            (content (with-output-to-blob (display body)))
+            (key (make-post-key (timestamp->date timestamp)
+                                (title->name title)))
+            (message (format #f "new post: \"~a\"" title)))
+        (post-from-key
+         (git-update-ref
+          "refs/heads/master"
+          (lambda (master)
+            (git-commit-tree (munge-tree master
+                                         `(((,key)
+                                            . ("metadata" ,metadata blob))
+                                           ((,key)
+                                            . ("content" ,content blob)))
+                                         '()
+                                         '())
+                             master message #f))
+          5)
+         key
+         #t)))))
+
 (define (all-posts master)
   (map (lambda (pair)
          (post-from-tree (car pair) (cdr pair)))

tekuti/util.scm

@@ -35,6 +35,7 @@
             call-with-temp-file emailish? urlish?
             date-increment date-comparator date-before? date-after? compose1
             rfc822-date->timestamp timestamp->rfc822-date timestamp->atom-date
+            timestamp->date
             list-intersperse with-backtrace with-time-debugging define-memoized))
 
 (define (emailish? x)
@@ -244,11 +245,14 @@
                    (string->date str "~a, ~d ~b ~Y ~H:~M:~S GMT")))
      (date-zone-offset (current-date))))
 
+(define (timestamp->date timestamp)
+  (time-utc->date (make-time time-utc 0 timestamp) 0))
+
 (define (timestamp->atom-date timestamp)
-  (date->string (time-utc->date (make-time time-utc 0 timestamp) 0)
+  (date->string (timestamp->date timestamp)
                 "~Y-~m-~dT~H:~M:~SZ"))
 
 (define (timestamp->rfc822-date timestamp)
-  (date->string (time-utc->date (make-time time-utc 0 timestamp) 0)
+  (date->string (timestamp->date timestamp)
                 "~a, ~d ~b ~Y ~H:~M:~S GMT"))
 

tekuti/web.scm

@@ -38,6 +38,7 @@
 (define *status-names*
   '((200 . "OK")
     (201 . "Created")
+    (303 . "See Other")
     (304 . "Not Modified")
     (401 . "Unauthorized")
     (404 . "Not Found")