another checkpoint, tag cloud working...

tekuti/page.scm

@@ -60,9 +60,6 @@
 (define (make-post-key . parts)
   (url:encode (format #f "~{~a~^/~}" (map url:encode parts))))
 
-(define (show-post slug index)
-  `(sxml . (p "hello" ,slug)))
-
 (define (not-implemented request . args)
   (rcons* request
           'status 500
@@ -89,20 +86,37 @@
   `(div (@ (id "menu"))
         (ul ,@body)))
 
+(define (with-authentication request thunk)
+  (let ((headers (rref request 'headers '())))
+    (define (authenticated?)
+      (let ((b64 (assoc-ref headers "Authorization")))
+        (pk b64) ;; FIXME, decode
+        ))
+    (if (authenticated?)
+        (thunk)
+        (rcons* (rpush 'output-headers
+                      '("WWW-Authenticate" . "Basic realm=\"Tekuti\"")
+                      request)
+                'status 401
+                'body `((p "Authentication required, yo"))))))
+
 (define (page-admin request index)
-  ;; here we need to be giving a dashboard view instead of this
+  (with-authentication
-  (define (post-links n)
+   request
-    (mapn (lambda (post)
+   (lambda ()
-            `(li ,(admin-post-link post)))
+     ;; here we need to be giving a dashboard view instead of this
-          (assq-ref index 'posts)
+     (define (post-links n)
-          n))
+       (mapn (lambda (post)
-  (rcons* request
+               `(li ,(admin-post-link post)))
-          'body `(,(sidebar-ul `((li (h2 ,(relurl "admin/posts" "posts"))
+             (assq-ref index 'posts)
-                                     (ul ,@(post-links 10)))
+             n))
-                                 (li (h2 "recent comments")
+     (rcons* request
-                                     (p "ain't got none"))))
+             'body `(,(sidebar-ul `((li (h2 ,(relurl "admin/posts" "posts"))
-                  (h2 "new post")
+                                        (ul ,@(post-links 10)))
-                  ,(post-editing-form #f))))
+                                    (li (h2 "recent comments")
+                                        (p "ain't got none"))))
+                     (h2 "new post")
+                     ,(post-editing-form #f))))))
 
 (define (admin-post-link post)
   (relurl (string-append "admin/posts/"
@@ -114,22 +128,27 @@
           (assq-ref post 'title)))
 
 (define (page-admin-posts request index)
-  (define (post-headers)
+  (with-authentication
-    (map (lambda (post)
+   request
-           ;; double-encoding is a hack to trick apache
+   (lambda ()
-           `(h3 ,(relurl (string-append "admin/posts/" (url:encode (assq-ref post 'key)))
+     (define (post-headers)
-                         (assq-ref post 'title))))
+       (map (lambda (post)
-         (assq-ref index 'posts)))
+              ;; double-encoding is a hack to trick apache
-  (rcons* request
+              `(h3 ,(relurl (string-append "admin/posts/" (url:encode (assq-ref post 'key)))
-          'body `((h1 "all your posts are belong to tekuti")
+                            (assq-ref post 'title))))
-                  ,@(post-headers))))
+            (assq-ref index 'posts)))
+     (rcons* request
+             'body `((h1 "all your posts are belong to tekuti")
+                     ,@(post-headers))))))
 
 (define (page-admin-post request index key)
-  (let ((post (post-from-key (assq-ref index 'master) key)))
+  (with-authentication
-    (pk 'foo post)
+   request
-    (rcons* request
+   (lambda ()
-          'body `((h1 ,(assq-ref post 'title))
+     (let ((post (post-from-key (assq-ref index 'master) key)))
-                  ,(post-editing-form post)))))
+       (rcons* request
+               'body `((h1 ,(assq-ref post 'title))
+                       ,(post-editing-form post)))))))
 
 (define (decode-form-data request)
   (let-request request (headers post-data)
@@ -150,14 +169,17 @@
             (error "bad content-type" content-type)))))))
 
 (define (page-admin-new-post request index)
-  (let ((form-data (decode-form-data request)))
+  (with-authentication
-    (rcons* request
+   request
-            'status 201         ; created
+   (lambda ()
-            'output-headers (acons "Location" *public-url-base*
+     (let ((form-data (decode-form-data request)))
-                                   (rref request 'output-headers '()))
+       (rcons* request
-            'body `((h1 "Created")
+               'status 201              ; created
-                    (p "Created new post: " ,(assoc-ref form-data "title"))
+               'output-headers (acons "Location" *public-url-base*
-                    (pre ,(assoc-ref form-data "body"))))))
+                                      (rref request 'output-headers '()))
+               'body `((h1 "Created")
+                       (p "Created new post: " ,(assoc-ref form-data "title"))
+                       (pre ,(assoc-ref form-data "body"))))))))
 
 (define (show-post post comments?)
   `((h2 (@ (class "storytitle"))
@@ -169,25 +191,72 @@
                                       " | ")
              ")")
          (div (@ (class "storycontent"))
-              ,(post-sxml-content post)))
+              ,(post-sxml-content post))
-    ,(if comments?
+         ,@(if comments? '()
-         (post-sxml-comments post)
+               (list (post-sxml-n-comments post))))
-         (post-sxml-n-comments post))))
+    ,@(if comments?
+          (list (post-sxml-comments post))
+          '())))
 
 ;;                     (a (@ (href ,new-url)) ,new-url)
 
 (define (page-admin-modify-post request index key)
-  (not-implemented request index))
+  (with-authentication
+   request
+   (lambda ()
+     (not-implemented request index))))
 (define page-new-comment not-implemented)
 (define page-delete-comment not-implemented)
 (define page-delete-post not-implemented)
 
+(define (tag-cloud index)
+  (define (determine-sizes counts)
+    (let ((maxcount (apply max counts)))
+      (map (lambda (x)
+             (floor (+ 80 (* 120 (/ x maxcount)))))
+           counts)))
+  (let* ((cats (hash-fold (lambda (k v seed) (acons k (length v) seed))
+                          '() (assq-ref index 'categories)))
+         (top-20 (dsu-sort (take-max (dsu-sort cats cdr >) 20)
+                           car string<?)))
+    `(ul (li (@ (style "line-height: 150%"))
+             ,@(list-intersperse
+                (map (lambda (name size)
+                       `(a (@ (href ,(string-append
+                                      *public-url-base* "tags/"
+                                      (url:encode name)))
+                              (rel "tag")
+                              (style ,(format #f "font-size: ~d%" size)))
+                           ,name))
+                     (map car top-20)
+                     (determine-sizes (map cdr top-20)))
+                " "))
+         )))
+
+(define (main-sidebar request index)
+  (sidebar-ul
+   `((li (h2 "orbit")
+         (ul
+          ,@(map (lambda (pair)
+                   `(li (a (@ (href ,(car pair))) ,(cdr pair))))
+                 '(("http://advogato.org/recentlog.html?thresh=3" . "advogato")
+                   ("http://ambient.2y.net/" . "ambient")
+                   ("http://planet.gnome.org/" . "gnome")
+                   ("http://gstreamer.freedesktop.org/planet/" . "gstreamer")
+                   ("http://planet.lisp.org/" . "lisp")))))
+     (li (h2 "tags "
+             (a (@ (href ,(string-append *public-url-base* "tags/")))
+                ">>"))
+         ,(tag-cloud index)))))
+
+
 (define (page-index request index)
   (rcons* request
           'title "my bloggidy blog"
-          'body (map (lambda (post)
+          'body `(,(main-sidebar request index)
-                       (show-post post #f))
+                  ,@(map (lambda (post)
-                     (take-max (assq-ref index 'posts) 10))))
+                           (show-post post #f))
+                         (take-max (assq-ref index 'posts) 10)))))
 
 (define (page-show-post request index year month day post)
   (let ((slug (make-post-key year month day post)))

tekuti/web.scm

@@ -38,6 +38,7 @@
 (define *status-names*
   '((200 . "OK")
     (201 . "Created")
+    (401 . "Unauthorized")
     (404 . "Not Found")
     (500 . "Internal Server Error")))