atom feed maybe working

7 files changed, 169 insertions, 73 deletions

diff --git a/tekuti/comment.scm b/tekuti/comment.scm
index 93d519d..2454516 100644
--- a/tekuti/comment.scm
+++ b/tekuti/comment.scm
@@ -34,7 +34,7 @@
   #:use-module (sxml transform)
   #:use-module (match-bind)
   #:export (comment-from-object comment-sxml-content comment-timestamp build-comment-skeleton comment-readable-date
-            bad-new-comment-post?))
+            bad-new-comment-post? make-new-comment))
 
 (define *comment-spec*
   `((timestamp . ,string->number)))
@@ -102,7 +102,7 @@
       `(p "Please pretend to specify a valid email address.")))
 
 (define (urlish? x)
-  (match-bind "^https?://([a-zA-Z0-9-]+\\.)+[a-zA-Z]+/.*$"
+  (match-bind "^https?://([a-zA-Z0-9-]+\\.)+[a-zA-Z]+/[a-zA-Z0-9$_.+!*'(),;/?:@&=-]*$"
               x (_ . args)
               x
               #f))
@@ -213,42 +213,44 @@
        (if (not (assoc name dent-names))
            (error "file already removed" name)))
      names))
-  (define (collect proc l)
-    (reverse! (fold (lambda (x y)
-                      (let ((foo (proc x)))
-                        (if foo (cons foo y) y)))
-                    '() l)))
-  (define (level-down x)
-    (cons (cdar x) (cdr x)))
-  
-  (let-values (((dents) (git-ls-tree treeish #f))
+  (let-values (((dents) (if treeish (git-ls-tree treeish #f) '()))
                ((ladd dadd) (partition local? add))
                ((lremove dremove) (partition local? remove))
                ((lchange dchange) (partition local? change)))
-    (assert-added-files-not-present (map caadr ladd) dents)
+    (assert-added-files-not-present (map cadr ladd) dents)
     (assert-referenced-files-present
-     (append (map cadr lremove) (map caadr lchange)) dents)
-    
-    (make-tree
-     (append
-      (map cdr ladd)
-      (collect
-       (lambda (dent)
-         (cond
-          ((member (car dent) (map cadr lremove))
-           #f)
-          ((member (car dent) (map caadr lchange))
-           (cadr lchange))
-          ((and (equal? (caddr dent) "tree")
-                (or (member (car dent)
-                            (map cadr (append dadd dremove dchange)))))
-           `(,(car dent) (make-tree-deep (cadr dent)
-                                         (map level-down dadd)
-                                         (map level-down dremove)
-                                         (map level-down dchange))
-             ,(caddr dent) ,(cadddr dent)))
-          (else dent))))))))
-  
+     (append (map cdr lremove) (map caar lchange)) dents)
+    (pk 'make-tree-deep treeish add remove change)
+    (make-tree-full
+     (pk 'making (append
+       (map cdr ladd)
+       (filter-map
+        (lambda (dent)
+          (cond
+           ((member (car dent) (map cdr lremove))
+            #f)
+           ((member (car dent) (map cadr lchange))
+            (cdr lchange))
+           ((and (equal? (caddr dent) "tree")
+                 (member (car dent)
+                         (map caar (append dadd dremove dchange))))
+            (pk 'hi! dent (map caar (append dadd dremove dchange)))
+            (let ((level-down (lambda (x)
+                                (if (equal? (caar x) (car dent))
+                                    (cons (cdar x) (cdr x))
+                                    #f))))
+              (list (car dent)
+                    (make-tree-deep (cadr dent)
+                                    (filter-map level-down dadd)
+                                    (filter-map level-down dremove)
+                                    (filter-map level-down dchange))
+                    "tree" "040000")))
+           (else dent)))
+        (append (filter-map (lambda (x)
+                              (and (not (assoc (caar x) dents))
+                                   (list x "tree" #f #f))
+                              dadd))
+                dents)))))))
     
 (define (mutate-tree master add remove change message)
   (let ((tree (make-tree-deep master add remove change)))
@@ -256,9 +258,9 @@
      (git* `("commit-tree" ,tree "-p" ,master) #:input message
            #:env '("GIT_COMMMITTER=tekuti")))))
 
-(define (update-master master proc)
-  (let lp ((master master))
-    (let ((commit (proc master)) (count 5))
+(define (update-master proc)
+  (let lp ((master (git-rev-parse "master")) (count 5))
+    (let ((commit (proc master)))
       (cond
        ((zero? count)
         (error "my god, we looped 5 times" commit))
@@ -269,21 +271,31 @@
         (pk "failed to update the master ref, trying again...")
         (lp (git-rev-parse "master") (1- count)))))))
 
-(define (make-new-comment post content)
-  (let ((content-sha1 (make-blob 
-(assoc-ref post-data "comment")))
-        (metadata-sha1 (make-blob (with-output-to-string
-                                    (lambda ()
-                                      (write )
-                                      )
-) metadata)))
-    (update-master
-     master
-     (lambda (master)
-       (mutate-tree master
-                    `(((,(assq-ref post 'key) "comments" ,comment-key)
-                       ("content" ,content-sha1 "blob" "100644"))
-                      ((,(assq-ref post 'key) "metadata" ,comment-key)
-                       ("metadata" ,metadata-sha1 "blob" "100644")))
-                    '()
-                    '())))))
+(define (make-new-comment post post-data)
+  (let ((content (assoc-ref post-data "comment"))
+        (author (assoc-ref post-data "author"))
+        (email (assoc-ref post-data "email"))
+        (url (assoc-ref post-data "url"))) 
+    (let ((sha1 (create-blob 
+                 (with-output-to-string
+                   (lambda ()
+                     (for-each
+                      (lambda (pair)
+                        (format #t "~a: ~a\n" (car pair) (cdr pair)))
+                      `((timestamp . ,(time-second (current-time)))
+                        (author . ,(string-join
+                                    ;; security foo
+                                    (string-split author #\newline)
+                                    " "))
+                        (author_email . ,email)
+                        (author_url . ,url)))
+                     (display "\n")
+                     (display content))))))
+      (update-master
+       (lambda (master)
+         (mutate-tree master
+                      `(((,(assq-ref post 'key) "comments") . (,sha1 ,sha1 "blob" "100644")))
+                      '()
+                      '()
+                      "new comment"))))))
+
diff --git a/tekuti/config.scm b/tekuti/config.scm
index 3899f2d..e3d605f 100644
--- a/tekuti/config.scm
+++ b/tekuti/config.scm
@@ -27,7 +27,8 @@
 (define-module (tekuti config)
   #:use-module (tekuti util)
   #:export (*host* *port* *backlog* *git-dir* *git* *public-url-base*
-            *private-url-base* *debug* *admin-user* *admin-pass*))
+            *private-url-base* *debug* *admin-user* *admin-pass*
+            *title* *name*))
 
 (define *host* "127.0.0.1")
 (define *port* 8081)
@@ -39,3 +40,6 @@
 (define *debug* #t)
 (define *admin-user* "admin")
 (define *admin-pass* "totingiini")
+(define *title* "My blog")
+(define *subtitle* "Just a blog, ok")
+(define *name* "Joe Schmo")
diff --git a/tekuti/git.scm b/tekuti/git.scm
index 09c12e2..aede954 100644
--- a/tekuti/git.scm
+++ b/tekuti/git.scm
@@ -63,7 +63,7 @@
 		(string->list str))
       (display #\'))))
       
-(define *debug* #f)
+(define *debug* #t)
 (define (trc . args)
   (if *debug*
       (apply pk args)
diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm
index da2e7fa..c17a3ac 100644
--- a/tekuti/mod-lisp.scm
+++ b/tekuti/mod-lisp.scm
@@ -69,8 +69,20 @@
   (display "end\n" port))
 
 (define (write-body request socket)
-  (display (rref request 'doctype "") socket)
-  (sxml->xml (rref request 'sxml '()) socket))
+  (let ((sxml (rref request 'sxml #f)))
+    (if sxml
+        (begin (display (rref request 'doctype "") socket)
+               (sxml->xml sxml socket))
+        (display "" socket))))
+
+(define (request-output-headers request)
+  (let ((rheads '(("Content-Type" . output-type))))
+    (map (lambda (h)
+           (cons (car h)
+                 (or (and=> (assoc-ref (car h) rheads)
+                            (lambda (k) (rref request k #f)))
+                     (cdr h))))
+         (rref request 'output-headers '()))))
 
 (define (connection-received socket sockaddr index)
   (let* ((headers (pk (read-headers socket)))
@@ -84,7 +96,7 @@
        (let ((res (handle-request (make-request 'headers headers
                                                 'post-data post-data)
                                   index)))
-         (write-headers (rref res 'output-headers '()) socket)
+         (write-headers (request-output-headers res) socket)
          (write-body res socket)))
      (lambda args
        (write-headers '(("Status" . "500 Internal Server Error")
diff --git a/tekuti/page.scm b/tekuti/page.scm
index dc26b43..bf8d7c0 100644
--- a/tekuti/page.scm
+++ b/tekuti/page.scm
@@ -51,11 +51,16 @@
             page-debug 
             page-search 
             page-show-post 
+            page-feed-atom
+            page-feed-rss2
             page-debug
             page-not-found))
 
-(define (relurl path . body)
-  `(a (@ (href ,(string-append *public-url-base* path)))
+(define (relurl path)
+  (string-append *public-url-base* path))
+
+(define (rellink path . body)
+  `(a (@ (href ,(relurl path)))
       ,@body))
 
 (define (make-post-key . parts)
@@ -107,7 +112,7 @@
              (assq-ref index 'posts)
              n))
      (rcons* request
-             'body `(,(sidebar-ul `((li (h2 ,(relurl "admin/posts" "posts"))
+             'body `(,(sidebar-ul `((li (h2 ,(rellink "admin/posts" "posts"))
                                         (ul ,@(post-links 10)))
                                     (li (h2 "recent comments")
                                         (p "ain't got none"))))
@@ -115,12 +120,12 @@
                      ,(post-editing-form #f))))))
 
 (define (admin-post-link post)
-  (relurl (string-append "admin/posts/"
+  (rellink (string-append "admin/posts/"
                          (url:encode (assq-ref post 'key)))
           (assq-ref post 'title)))
 
 (define (post-link post)
-  (relurl (string-append "archives/" (url:decode (assq-ref post 'key)))
+  (rellink (string-append "archives/" (url:decode (assq-ref post 'key)))
           (assq-ref post 'title)))
 
 (define (page-admin-posts request index)
@@ -130,7 +135,7 @@
      (define (post-headers)
        (map (lambda (post)
               ;; double-encoding is a hack to trick apache
-              `(h3 ,(relurl (string-append "admin/posts/" (url:encode (assq-ref post 'key)))
+              `(h3 ,(rellink (string-append "admin/posts/" (url:encode (assq-ref post 'key)))
                             (assq-ref post 'title))))
             (assq-ref index 'posts)))
      (rcons* request
@@ -262,8 +267,9 @@
                   (rcons* request
                           'body `((p "Bad post data: " ,reason)))))
             (else
-             (rcons* request
-                     'body `((p "hey hey hey like fat albert")))))))
+             (let ((comment (make-new-comment (post-from-tree slug tree) data)))
+               (rcons* request
+                       'body `((p "hey hey hey like fat albert" ,comment))))))))
      (else
       (page-not-found request index)))))
 
@@ -356,3 +362,59 @@
           'status 404
           'body `((h1 "Page not found")
                   (p "Unknown path: " ,(rref request 'path-str)))))
+
+(define (page-feed-rss2 request index)
+  (not-implemented request index))
+
+
+(define (rfc822-date->timestamp str)
+  (+ (time-second (date->time-utc
+                   (string->date str "~a, ~d ~b ~Y ~H:~M:~S GMT")))
+     (date-zone-offset (current-date))))
+
+(define (timestamp->atom-date timestamp)
+  (date->string (time-utc->date (make-time time-utc 0 timestamp) 0)
+                "~Y-~m-~dT~H:~M:~SZ"))
+
+(define (page-feed-atom request index)
+  (let ((last-modified (let ((posts (assq-ref index 'posts)))
+                         (and (pair? posts)
+                              (assq-ref (car posts) 'timestamp)))))
+    (cond
+     ((let ((since (assoc-ref (rref request 'headers '())
+                              "If-Modified-Since")))
+        (and since (>= (rfc822-date->timestamp since) last-modified)))
+      (rcons* request
+              'status 304
+              'doctype #f))
+     (else
+      (rcons* request
+              'doctype ""
+              'output-type "application/atom+xml"
+              'sxml `(feed
+                      (@ (xmlns "http://www.w3.org/2005/Atom")
+                         (xml:base ,(relurl "feed/atom")))
+                      (title (@ (type "text")) ,*title*)
+                      (subtitle (@ (type "text")) ,*subtitle*)
+                      (updated ,(timestamp->atom-date last-modified))
+                      (generator (@ (uri "http://wingolog.org/software/tekuti")
+                                    (version "what"))
+                                 "tekuti")
+                      (link (@ (rel "alternate") (type "text/html")
+                               (href ,(relurl ""))))
+                      (id ,(relurl "feed/atom"))
+                      (link (@ (rel "self") (type "application/atom+xml")
+                               (href ,(relurl "feed/atom"))))
+                      ,@(map
+                         (lambda (post)
+                           `(entry
+                             (author (name ,*name*) (uri ,(relurl "")))
+                             (title (@ (type "text")) ,(assq-ref post 'title))
+                             (id ,(assq-ref post 'key))
+                             (published ,(timestamp->atom-date
+                                          (assq-ref post 'timestamp)))
+                             (content (@ (type "xhtml")
+                                         (xmlns "http://www.w3.org/1999/xhtml"))
+                                      (div ,(post-sxml-content post)))))
+                         (take-max (assq-ref index 'posts) 10))))))))
+
diff --git a/tekuti/post.scm b/tekuti/post.scm
index 7177d12..cafd4e0 100644
--- a/tekuti/post.scm
+++ b/tekuti/post.scm
@@ -166,7 +166,7 @@
                  ,(comment-form post "" "" "" ""))))))
 
 (define (post-n-comments post)
-  (length (git-ls-subdirs (assq-ref post 'sha1) "comments/")))
+  (length (git-ls-subdirs (string-append (assq-ref post 'sha1) ":comments") #f)))
 
 (define (post-sxml-n-comments post)
   `(div (@ (class "feedback"))
diff --git a/tekuti/web.scm b/tekuti/web.scm
index 278dd2f..6028ea3 100644
--- a/tekuti/web.scm
+++ b/tekuti/web.scm
@@ -38,6 +38,7 @@
 (define *status-names*
   '((200 . "OK")
     (201 . "Created")
+    (304 . "Not Modified")
     (401 . "Unauthorized")
     (404 . "Not Found")
     (500 . "Internal Server Error")))
@@ -51,6 +52,7 @@
    "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
    "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"))
 
+;; what the hell is this
 (define (request-output-headers request)
   (let-request request ((output-headers '())
                         (status 200)
@@ -73,9 +75,10 @@
 (define (finalize request)
   ;; update output headers
   ;; templatize body
-  (rpush* (rcons* request
-                  'sxml (templatize request)
-                  'doctype xhtml-doctype)
+  (rpush* (if (assq 'sxml request)
+              request
+              (rcons 'sxml (templatize request)
+                     request))
           'output-headers
           (cons "Status" (status->string (rref request 'status 200)))
           'output-headers
@@ -98,6 +101,9 @@
    ((GET archives year? month? day?) page-archives)
    ((GET archives year! month! day! post!) page-show-post)
    ((POST archives year! month! day! post!) page-new-comment)
+   ((GET feed) page-feed-rss2)
+   ((GET feed rss2) page-feed-rss2)
+   ((GET feed atom) page-feed-atom)
    ((GET tags) page-show-tags)
    ((GET tags tag!) page-show-tag)
    ((GET debug) page-debug)
@@ -106,4 +112,4 @@
 
 (define (handle-request request index)
   (let ((handler (choose-handler request)))
-    (pk (finalize (handler request index)))))
+    (finalize (handler (rcons 'doctype xhtml-doctype request) index))))