post.scm

(define-module (tekuti post)
  #:use-module (srfi srfi-1)
  #:use-module (web uri)
  #:use-module (tekuti match-bind)
  #:use-module (tekuti util)
  #:use-module (tekuti comment)
  #:use-module (tekuti config)
  #:use-module (tekuti git)
  #:use-module (tekuti filters)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:export (post-from-key

            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 modify-post delete-post

            latest-posts

            reindex-posts reindex-posts-by-date))

;;;
;;; pulling posts out of git
;;;

(define *post-spec*
  `((timestamp . ,string->number)
    (tags . ,(lambda (v) (string-split/trimming v #\,)))
    (title . ,identity)))

(define (post-from-tree encoded-name sha1)
  (append `((key . ,encoded-name)
            (sha1 . ,sha1))
          (match-lines
           (git "show" (string-append sha1 ":metadata"))
           "^([^: ]+): +(.*)$" (_ k v)
           (let* ((k (string->symbol k))
                  (parse (or (assq-ref *post-spec* k)
                             identity)))
             (cons k (parse v))))))

(define (post-from-git master key)
  (false-if-git-error
   (let ((pairs (git-ls-subdirs master key)))
     (and (= (length pairs) 1)
          (post-from-tree key (cdar pairs))))))

;;;
;;; pulling posts out of the index
;;;

(define* (post-from-key index key #:key allow-unpublished?)
  (let ((post (hash-ref (assq-ref index 'posts) key)))
    (if (and post (or (post-published? post) allow-unpublished?))
        post
        #f)))

;;;
;;; accessors
;;;

(define (post-published? post-alist)
  (equal? (assq-ref post-alist 'status) "publish"))

(define (post-timestamp post-alist)
  (assq-ref post-alist 'timestamp))

(define (post-tags post-alist)
  (or (assq-ref post-alist 'tags) '()))

(define (post-key post)
  (assq-ref post 'key))

(define (post-title post)
  (assq-ref post 'title))

(define (post-comments-open? post)
  (equal? (assq-ref post 'comment_status) "open"))

(define (post-raw-content post)
  (git "show" (string-append (assq-ref post 'sha1) ":content")))

(define (post-sxml-content post)
  (let ((format (or (assq-ref post 'format) 'wordpress))
        (raw (post-raw-content post)))
    (catch #t
           (lambda ()
             (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))))))