basic archives done

tekuti/comment.scm

@@ -28,8 +28,10 @@
 (define-module (tekuti comment)
   #:use-module (tekuti git)
   #:use-module (tekuti util)
+  #:use-module (tekuti filters)
   #:use-module (srfi srfi-1)
-  #:export (comment-from-tree build-comment-skeleton))
+  #:use-module (srfi srfi-19)
+  #:export (comment-from-tree comment-sxml-content comment-timestamp build-comment-skeleton comment-readable-date))
 
 (use-modules (ice-9 rdelim)
              (ice-9 popen)
@@ -43,7 +45,24 @@
   `((timestamp . ,string->number)))
 (define (comment-from-tree encoded-name sha1)
   (acons 'encoded-name encoded-name
-         (parse-metadata (string-append sha1 ":" "metadata") *comment-spec*)))
+         (acons 'sha1 sha1
+                (parse-metadata (string-append sha1 ":" "metadata")
+                                *comment-spec*))))
+
+(define (comment-readable-date comment)
+  (let ((date (time-utc->date
+               (make-time time-utc 0 (assq-ref comment 'timestamp)))))
+    (date->string date "~e ~B ~Y ~l:~M ~p")))
+
+(define (comment-raw-content comment)
+  (git "show" (string-append (assq-ref comment 'sha1) ":content")))
+
+(define (comment-sxml-content comment)
+  (let ((format (or (assq-ref comment 'format) 'wordpress)))
+    ((case format
+       ((wordpress) wordpress->sxml)
+       (else (lambda (text) `(pre ,text))))
+     (comment-raw-content comment))))
 
 (define (comment-timestamp comment-alist)
   (or (assq-ref comment-alist 'timestamp) #f))

tekuti/git.scm

@@ -135,9 +135,11 @@
                (list name object type mode)))
 
 (define (git-ls-subdirs treeish path)
+  (or (false-if-git-error
        (match-lines (git "ls-tree" treeish (or path "."))
                     "^(.+) tree (.+)\t(.+)$" (_ mode object name)
                     (cons name object)))
+      '()))
 
 (define (parse-metadata treeish specs)
   (filter

tekuti/page.scm

@@ -32,6 +32,8 @@
   #:use-module (tekuti url)
   #:use-module (tekuti request)
   #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-19)
+  #:use-module (scheme kwargs)
   #:export (page-admin
             page-admin-posts
             page-admin-post
@@ -43,6 +45,8 @@
             page-index 
             page-show-post 
             page-archives 
+            page-show-tags
+            page-show-tag
             page-debug 
             page-search 
             page-show-post 
@@ -155,7 +159,7 @@
                     (p "Created new post: " ,(assoc-ref form-data "title"))
                     (pre ,(assoc-ref form-data "body"))))))
 
-(define (show-post post)
+(define (show-post post comments?)
   `((h2 (@ (class "storytitle"))
         ,(post-link post))
     (div (@ (class "post"))
@@ -165,7 +169,10 @@
                                       " | ")
              ")")
          (div (@ (class "storycontent"))
-              ,(post-sxml-content post)))))
+              ,(post-sxml-content post)))
+    ,(if comments?
+         (post-sxml-comments post)
+         (post-sxml-n-comments post))))
 
 ;;                     (a (@ (href ,new-url)) ,new-url)
 
@@ -186,11 +193,80 @@
              (pk post)
              (rcons* request
                      'title (assq-ref post 'title)
-                     'body (show-post post)))))
+                     'body (show-post post #t)))))
      (else
       (page-not-found request index)))))
 
-(define page-archives not-implemented)
+(define/kwargs (date-increment date (day 0) (month 0) (year 0))
+  (make-date (date-nanosecond date) (date-second date)
+             (date-minute date) (date-minute date)
+             (+ (date-day date) day) (+ (date-month date) month)
+             (+ (date-year date) year) (date-zone-offset date)))
+
+(define (date-comparator date comp)
+  (let ((this (time-second (date->time-utc date))))
+    (lambda (that)
+      (comp that this))))
+
+(define (date-before? date)
+  (date-comparator date <))
+
+(define (date-after? date)
+  (date-comparator date >))
+
+(define (compose1 proc . procs)
+  (if (null? procs)
+      proc
+      (let ((other (apply compose1 procs)))
+        (lambda (x)
+          (proc (other x))))))
+
+;; fixme exception handling for input
+(define (page-archives request index year month day)
+  (let ((year (and=> year string->number))
+        (month (and=> month string->number))
+        (day (and=> day string->number)))
+    (let ((start (make-date 0 0 0 0 (or day 1) (or month 1) (or year 1980) 0)))
+      (define too-early?
+        (compose1 (date-before? start) post-timestamp))
+      (define early-enough?
+        (if year
+            (compose1 (date-before?
+                       (cond (day (date-increment start #:day 1))
+                             (month (date-increment start #:month 1))
+                             (else (date-increment start #:year 1))))
+                      post-timestamp)
+            (lambda (post) #t)))
+      (define (make-date-header post)
+        (lambda (x) #f))
+    
+      (let lp ((posts (assq-ref index 'posts)))
+        (pk 'foo (or (null? posts) (car posts)))
+        (cond ((or (null? posts) (too-early? (car posts)))
+               (rcons* request
+                       'title "no posts found"
+                       'body `((h1 "No posts found")
+                               (p "No posts were found in the specified period."))))
+              ((early-enough? (car posts))
+               (let lp ((posts posts) (new-header (make-date-header #t)) (out '()))
+                 (cond
+                  ((or (null? posts) (too-early? (car posts)))
+                   (rcons* request
+                           'title "archives"
+                           'body (reverse out)))
+                  ((new-header (car posts))
+                   => (lambda (sxml)
+                        (lp (cdr posts) (make-date-header (car posts))
+                            (cons (post-link (car posts)) (append sxml out)))))
+                  (else
+                   (lp (cdr posts) new-header (cons `(p ,(post-link (car posts))) out))))))
+              (else (lp (cdr posts))))))))
+
+(define (page-show-tags request index)
+  (not-implemented request index))
+
+(define (page-show-tag request index tag)
+  (not-implemented request index))
 
 (define (page-debug request index)
   (rcons* request

tekuti/post.scm

@@ -28,14 +28,19 @@
   #:use-module (srfi srfi-1)
   #:use-module (match-bind)
   #:use-module (tekuti util)
+  #:use-module (tekuti url)
   #: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 (reindex-posts post-from-tree post-from-key post-categories
+                          post-timestamp
             post-sxml-content post-raw-content all-published-posts
-            post-readable-date post-category-links))
+            post-readable-date post-category-links post-sxml-n-comments
+            post-sxml-comments))
+
   
 ;; introducing new assumption: post urls like yyyy/dd/mm/post; post dirnames the urlencoded post
 
@@ -54,14 +59,14 @@
     (categories . ,(lambda (v) (map string-trim-both (string-split v #\,))))
     (title . ,identity)))
 
-(define-memoized (post-from-tree encoded-name sha1)
+(define (post-from-tree encoded-name sha1)
   (acons 'key encoded-name
-         (acons 'content-ref (string-append sha1 ":content")
+         (acons 'sha1 sha1
                 (parse-metadata (string-append sha1 ":metadata")
                                 *post-spec*))))
 
 (define (post-raw-content post)
-  (git "show" (assq-ref post 'content-ref)))
+  (git "show" (string-append (assq-ref post 'sha1) ":content")))
 
 (define (post-sxml-content post)
   (let ((format (or (assq-ref post 'format) 'wordpress)))
@@ -76,7 +81,11 @@
     (date->string date "~e ~B ~Y ~l:~M ~p")))
 
 (define (post-category-links post)
-  (post-categories post))
+  (map (lambda (cat)
+         `(a (@ (href ,(string-append *public-url-base* "tags/"
+                                      (url:encode cat))))
+             ,cat))
+       (post-categories post)))
 
 (define (post-from-key master key)
   (let ((pairs (git-ls-subdirs master key)))
@@ -92,15 +101,59 @@
   (dsu-sort
    (filter post-published? (all-posts master))
    post-timestamp
-   <))
+   >))
 
-(define (post-comments sha1)
+(define (post-comments post)
   (dsu-sort
    (map (lambda (pair)
           (comment-from-tree (car pair) (cdr pair)))
-        (git-ls-subdirs sha1 "comments/"))
+        (git-ls-subdirs (assq-ref post 'sha1) "comments/"))
    comment-timestamp
    <))
 
+(define (post-sxml-comments post)
+  (let ((comments (post-comments post))
+        (comment-status (assq-ref post 'comment_status)))
+    (define (n-comments-header)
+      (and (or (not (null? comments)) (equal? comment-status "open"))
+           `(h3 (@ (id "comments"))
+                ,(let ((len (length comments)))
+                   (case len
+                     ((0) "No responses")
+                     ((1) "One response")
+                     (else (format #f "~d responses" len)))))))
+    (define (show-comment comment)
+      `(li (@ (class "alt") (id ,(assq-ref comment 'encoded-name)))
+           (cite ,(let ((url (assq-ref comment 'author_url))
+                        (name (assq-ref comment 'author)))
+                    (if url
+                        `(a (@ (href ,url) (rel "external nofollow")) ,name)
+                        name)))
+           " says:" (br)
+           (small (@ (class "commentmetadata"))
+                  (a (@ (href ,(string-append
+                                "#" (assq-ref comment 'encoded-name))))
+                     ,(comment-readable-date comment)))
+           ,(comment-sxml-content comment)))
+    `(div
+      ,@(or (and=> (n-comments-header) list) '())
+      ,@(let ((l (map show-comment comments)))
+          (if (null? l) l
+              `((ol (@ (class "commentlist")) ,@l))))
+      ,(if (equal? comment-status "closed")
+           `(p (@ (id "nocomments")) "Comments are closed.")
+           '(div (h3 "Leave a Reply")
+                 "...")))))
+
+(define (post-n-comments post)
+  (length (git-ls-subdirs (assq-ref post 'sha1) "comments/")))
+
+(define (post-sxml-n-comments post)
+  `(div (@ (class "feedback"))
+        (a (@ (href ,(string-append *public-url-base* "/archives/"
+                                    (assq-ref post 'encoded-name)
+                                    "#comments")))
+           "(" ,(post-n-comments post) ")")))
+
 (define (reindex-posts index)
   (all-published-posts (assq-ref index 'master)))

tekuti/web.scm

@@ -97,6 +97,8 @@
    ((GET) page-index)
    ((GET archives year? month? day?) page-archives)
    ((GET archives year! month! day! post!) page-show-post)
+   ((GET tags) page-show-tags)
+   ((GET tags tag!) page-show-tag)
    ((GET debug) page-debug)
    ((POST search) page-search)
    (else page-not-found)))