post.scm

             (case format
               ((wordpress) (wordpress->sxml raw))
               (else `(pre ,raw))))
           (lambda args
             `(pre ,(bad-user-submitted-xhtml? raw))))))

(define (post-readable-date post)
  (let ((date (time-utc->date
               (make-time time-utc 0 (post-timestamp post)))))
    (date->string date "~e ~B ~Y ~l:~M ~p")))

(define (post-comments post)
  (dsu-sort
   (map (lambda (pair)
          (blob->comment (car pair) (cadr pair)))
        (git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f))
   comment-timestamp
   <))

(define (post-n-comments post)
  (length (git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f)))

(define (munge-post old-key parsed)
  (let ((metadata (with-output-to-blob
                   (for-each
                    (lambda (k)
                      (format #t "~a: ~a\n" k (assq-ref parsed k)))
                    '(timestamp tags status title name comment_status))))
        (content (with-output-to-blob (display (assq-ref parsed 'body))))
        (key (assq-ref parsed 'key))
        (message (format #f "~a: \"~a\""
                         (if old-key "post modified" "new post")
                         (assq-ref parsed 'title))))
    (define (maybe-rename ops)
      (if (and old-key (not (equal? old-key key)))
          (cons `(rename () (,old-key ,key)) ops)
          ops))
    (define (maybe-clear ops)
      (if old-key
          (append `((delete (,key) ("content"))
                    (delete (,key) ("metadata")))
                  ops)
          ops))
    (let ((ops (maybe-rename
                (maybe-clear
                 `((create (,key) ("metadata" ,metadata blob))
                   (create (,key) ("content" ,content blob)))))))
      (post-from-git
       (git-update-ref "refs/heads/master"
                       (lambda (master)
                         (git-commit-tree (munge-tree master ops)
                                          master message #f))
                       5)
       key))))

(define space-to-dash (s///g "[ .]" "-"))
(define remove-extraneous (s///g "[^a-z0-9-]+" ""))
(define collapse (s///g "-+" "-"))

(define (title->name title)
  (collapse (remove-extraneous (space-to-dash (string-downcase title)))))

;; some verification necessary...
(define (parse-post-data post-data)
  (let ((title (assoc-ref post-data "title"))
        (body (assoc-ref post-data "body"))
        (tags (assoc-ref post-data "tags"))
        (status (assoc-ref post-data "status"))
        (comments-open? (assoc-ref post-data "comments"))
        (date-str (assoc-ref post-data "date")))
    (let ((timestamp (if (string-null? date-str)
                         (time-second (current-time))
                         (rfc822-date->timestamp date-str)))
          (name (title->name title)))
      `((title . ,title)
        (body . ,body)
        (tags . ,tags)
        (status . ,status)
        (comment_status . ,(if comments-open? "open" "closed"))
        (timestamp . ,timestamp)
        (name . ,name)
        (key . ,(uri-encode
                 (string-append (date->string (timestamp->date timestamp)
                                              "~Y/~m/~d/")
                                (uri-encode name))))))))

(define (make-new-post post-data)
  (munge-post #f (parse-post-data post-data)))

(define (modify-post old-key post-data)
  (munge-post old-key (parse-post-data post-data)))

(define (delete-post post)
  (let ((message (format #f "~a: \"~a\"" "post deleted" (post-title post))))
    (git-update-ref "refs/heads/master"
                  (lambda (master)
                    (git-commit-tree
                     (munge-tree1 master 'delete '() `(,(post-key post)))
                     master message #f))
                  5)))

(define* (latest-posts index #:key allow-unpublished? (filter identity)
                       (limit 10))
  (filter-mapn
   (lambda (key)
     (and=> (post-from-key index key #:allow-unpublished? allow-unpublished?)
            (lambda (post) (and post (filter post) post))))
   (assq-ref index 'posts-by-date)
   limit))

(define (reindex-posts old-index index)
  (let ((old (assq-ref old-index 'posts))
        (new (make-hash-table)))
    (for-each
     (lambda (dent)
       (let* ((key (car dent))
              (sha1 (cadr dent))
              (prev (and (hash-table? old) (hash-ref old key))))
         (hash-set! new key
                    (if (and prev (equal? (assq-ref prev 'sha1) sha1))
                        prev
                        (begin
                          (pk 'updated dent)
                          (post-from-tree key sha1))))))
     (git-ls-tree (assq-ref index 'master) #f))
    new))

(define (reindex-posts-by-date old-index index)
  (map cdr
       (sort (hash-map->list (lambda (key post)
                               (cons (post-timestamp post) key))
                             (assq-ref index 'posts))
             (lambda (x y)
               (> (car x) (car y))))))