feat: add user-page

1 files changed, 91 insertions, 20 deletions

diff --git a/main.scm b/main.scm
index e26dd5c..ffdc081 100644
--- a/main.scm
+++ b/main.scm
@@ -1,6 +1,6 @@
 (import
   scheme (chicken base)
-  (chicken format) (chicken port) (chicken io) (chicken random)
+  (chicken format) (chicken port) (chicken io) (chicken random) (chicken time)
   (chicken process-context) (chicken irregex) (chicken condition)
   spiffy intarweb uri-common html-parser spiffy-request-vars
   sqlite3 sql-null
@@ -27,8 +27,12 @@
                 )")
     )
 
+(define (gen-id)
+  (+ (pseudo-random-integer 65536)
+     (* (current-seconds) 100000)))
+
 (define (create-post user content parent-id)
-  (let ([id (pseudo-random-integer 281474976710655)])
+  (let ([id (gen-id)])
     (if (and parent-id (not (equal? "" parent-id)))
       (execute db "insert into posts (id, user_id, content,parent_id) values (?, ?, ?, ?)"
                id user content parent-id)
@@ -84,6 +88,15 @@
                 GROUP BY p.id, p.user_id, p.content, p.created_at, p.parent_id
                 ORDER BY count(c.id) DESC, p.created_at ASC LIMIT 25" post-id))
 
+(define (get-user-posts user-id)
+  (map-row list db
+            "SELECT p.id, p.user_id, p.content, p.created_at, p.parent_id, count(c.id)
+                FROM posts p
+                LEFT JOIN posts c ON c.parent_id = p.id
+                WHERE p.parent_id IS NULL AND p.user_id = ?
+                GROUP BY p.id, p.user_id, p.content, p.created_at, p.parent_id
+                ORDER BY count(c.id) DESC, p.created_at DESC LIMIT 25" user-id))
+
 (define (delete-post post-id current-user)
   (first-result db "DELETE FROM posts
                 WHERE id = ? AND user_id = ?
@@ -114,12 +127,17 @@
 
 (define (lookup-user apikey) (hash-table-ref/default apikeys apikey #f))
 
-(define (get-current-user)
+(define (get-cookie key)
   (let* ([headers (request-headers (current-request))]
-         [cookie (header-value 'cookie headers)]
-         [apikey (if cookie (cdr cookie) #f)])
+         [cookies (header-values 'cookie headers)])
+    (alist-ref key cookies equal?)))
+
+(define (get-current-user)
+  (let ([apikey (get-cookie "apikey")])
     (if apikey (lookup-user apikey) #f)))
 
+(define (get-prev-path) (get-cookie "prev"))
+
 (define (post-path id) 
   (if
     (and id
@@ -128,8 +146,19 @@
     (string-append "/posts/" id)
     "/"))
 
-(define (post current-user p)
-    (let ([uri (string-append "/posts/" (id p))])
+(define (user-path id)
+  (if
+    (and id
+         (not (sql-null? id))
+         (not (equal? "" id)))
+    (string-append "/users/" id)
+    "/")
+  )
+
+
+(define (post current-user p . opts)
+    (let ([uri (post-path (id p))]
+          [hide-comments-link (find (cut equal? <> 'hide-comments-link) opts)])
       `(div (@ [class "post"] [id ,(id p)])
             ,(if (equal? current-user (user p))
                           `(a (@ [href ,(string-append
@@ -139,12 +168,12 @@
                                  [class "delete-button"])
                               "[delete]")
                           '())
-            (p (@ [style "min-height:0.5em"]) ,(content p))
+            (p (@ [style "min-height:0.5em;white-space:pre;"]) ,(content p))
             (div [@ (class "post-info")]
-                 (em "- " ,(user p))
+                 (em "- " (a (@ [href ,(user-path (user p))]) ,(user p)))
                  (span (@ [style "float:right;"])
-                       (a (@ [href ,uri] [style "margin-right:2px;"])
-                          "[" ,(children-count p) " comments]")
+                       ,(if hide-comments-link '() `(a (@ [href ,uri] [style "margin-right:2px;"])
+                          "[" ,(children-count p) " comments]"))
                        ,(created-at p)
                        )))))
 
@@ -155,7 +184,12 @@
                    [name "parent_id"]
                    [value ,(or parent-id "")]))
   (span 
-      (textarea (@ [id "content"] [name "content"] [value ""] [rows "5"] [cols "50"])))
+      (textarea (@ [maxlength "540"]
+                   [id "content"]
+                   [name "content"]
+                   [value ""]
+                   [rows "5"]
+                   [cols "50"])))
   (input (@ [id "submit"] [type "submit"] [value "Post"]))))
 
 (define (page inner) 
@@ -181,15 +215,18 @@
 
 (define (vote-to-flush-prompt)
   (let ([prompts '("Flush it all away!"
-                   "Drain the swamp!"
                    "Unclog the bog!"
+                   "Incinerate everything!"
                    "Vote for a Purge!")])
     (list-ref prompts (pseudo-random-integer (length prompts)))))
 
+(define (current-request-path) (uri-path (request-uri (current-request))))
+(define (current-request-path-string)
+    (apply string-append (cons "/" (intersperse (cdr (current-request-path)) "/"))))
 
 (define (get-route-param route param)
   (let ([pattern (second route)]
-        [path (uri-path (request-uri (current-request)))])
+        [path (current-request-path)])
   (first (find
            (lambda (x) (equal? (second x) (string-append ":" param)))
            (zip path pattern)))))
@@ -208,10 +245,22 @@
            (div "Votes so far: " ,(vote-count))
            (div ,inner))))
 
+(define (user-page current-user user posts)
+  (posts-page-outer (user-path user) current-user
+                    `(span
+                       ,(navbar current-user '(a (@ [href "/"]) "home"))
+                       (h2 ,user)
+                       ,(if (and current-user (equal? current-user user)) (new-post-form #f) '())
+                       ,(if (null? posts)
+                          "no posts yet!"
+                          (map (cut post current-user <>) posts))
+                       )))
+
 (define (posts-page current-user displayed-posts)
   (posts-page-outer "/" current-user
                     `(span
-                     ,(navbar current-user '(h2 "Posts"))
+                     ,(navbar current-user)
+                     '(h2 "Posts")
                        ,(if current-user (new-post-form #f) '())
                        ,(if (null? displayed-posts)
                           "no posts yet!"
@@ -238,8 +287,8 @@
                       `(span
                          ,(navbar current-user
                                   `(a (@ [href ,parent-path])
-                                      "return"))
-                      ,(post current-user p)
+                                      ,(if (equal? parent-path "/") "home" "parent")))
+                      ,(post current-user p 'hide-comments-link)
                       (h3 "Comments")
                       ,(if (null? comments)
                          "no comments yet!"
@@ -247,12 +296,25 @@
                       ,(if current-user (new-post-form (id p)) '())))))
 
 (define (get-next-path)
-  (let ([next ((request-vars 'query-string) 'next as-string)])
-    (if (irregex-match "^/posts/[0-9]*$" next)
-      next
+  (get-qp-path 'next))
+
+
+;; Use cookie instead???
+
+
+(define allowed-return-paths
+  '("^/posts/[0-9]*$"
+    "^/users/[A-z0-9_-]*$"))
+
+(define (get-qp-path qp)
+  (let ([p ((request-vars 'query-string) qp as-string)])
+    (if (and p (any (cut irregex-match <> p) allowed-return-paths))
+      p
       "/")))
 
 
+;(define (set-prev-cookie) `(set-cookie #(("prev" . ,(current-request-path-string)) ())))
+
 (define routes
   `(
     (GET (/ "style.css") ,(lambda (rt)
@@ -313,6 +375,15 @@
                        status: 'ok
                        body: (posts-page current-user displayed-posts)))))
 
+    (GET (/ "users" ":id") ,(lambda (rt)
+                              (let* ([current-user (get-current-user)]
+                                     [user-id (get-route-param rt "id")]
+                                     [posts (get-user-posts user-id)])
+                                    (send-response
+                                      headers: '((content-type text/html))
+                                      status: 'ok
+                                      body: (user-page current-user user-id posts)))))
+
     (GET (/ "posts" ":id") ,(lambda (rt) 
                               (let* ([current-user (get-current-user)]
                                      [post-id (get-route-param rt "id")]