redirect back to correct page on vote/unvote

1 files changed, 36 insertions, 24 deletions

diff --git a/main.scm b/main.scm
index 23ca00c..c87f294 100644
--- a/main.scm
+++ b/main.scm
@@ -1,11 +1,13 @@
 (import (chicken format) (srfi-1))
 (import spiffy intarweb uri-common html-parser (chicken port))
+(import spiffy-request-vars)
 (import (chicken io))
 (import sqlite3)
 (import sql-null)
 (import srfi-69)
 (import (chicken random))
 (import (chicken process-context))
+(import (chicken irregex))
 
 
 ;; db open and create
@@ -123,11 +125,22 @@
          [apikey (if cookie (cdr cookie) #f)])
     (if apikey (lookup-user apikey) #f)))
 
+(define (post-path id) 
+  (if
+    (and id
+         (not (sql-null? id))
+         (not (equal? "" id)))
+    (string-append "/posts/" id)
+    "/"))
+
 (define (post current-user p)
     (let ([uri (string-append "/posts/" (id p))])
       `(div (@ [class "post"] [id ,(id p)])
             ,(if (equal? current-user (user p))
-                          `(a (@ [href ,(string-append uri "/delete")]
+                          `(a (@ [href ,(string-append
+                                          uri
+                                          "/delete"
+                                          )]
                                  [class "delete-button"])
                               "[delete]")
                           '())
@@ -186,21 +199,22 @@
            (lambda (x) (equal? (second x) (string-append ":" param)))
            (zip path pattern)))))
 
-(define (posts-page-outer current-user inner)
+(define (posts-page-outer current-path current-user inner)
   (page `(div
            (em "Even Shitter than Twitter")
            (br)
            ,(if current-user
               (if (user-has-voted current-user)
-                '(a (@ [href "/unvote"]) unvote)
-                `(a (@ [href "/vote-to-flush"]) ,(vote-to-flush-prompt)))
+                `(a (@ [href ,(string-append "/unvote?next=" current-path)])
+                       unvote)
+                `(a (@ [href ,(string-append "/vote-to-flush?next=" current-path)])
+                    ,(vote-to-flush-prompt)))
               '())
            (div "Votes so far: " ,(vote-count))
-           (div
-             ,inner))))
+           (div ,inner))))
 
 (define (posts-page current-user displayed-posts)
-  (posts-page-outer current-user
+  (posts-page-outer "/" current-user
                     `(span
                      ,(navbar current-user '(h2 "Posts"))
                        ,(if current-user (new-post-form #f) '())
@@ -218,13 +232,14 @@
        ))
 
 (define (post-page current-user p comments)
-  (let* ([pid (parent-id p)]
-        [parent-path (if (or (not pid)
-                            (sql-null? pid)
-                            (equal? pid ""))
-                       "/"
-                       (string-append "/posts/" pid))])
-    (posts-page-outer current-user
+  (let* ([current-path (post-path (id p))]
+         [pid (parent-id p)]
+         [parent-path (if (or (not pid)
+                              (sql-null? pid)
+                              (equal? pid ""))
+                        "/"
+                        (string-append "/posts/" pid))])
+    (posts-page-outer current-path current-user
                       `(span
                          ,(navbar current-user
                                   `(a (@ [href ,parent-path])
@@ -236,14 +251,11 @@
                          (map (cut post current-user <>) comments))
                       ,(if current-user (new-post-form (id p)) '())))))
 
-(define (post-path id) 
-  (if
-    (and id
-         (not (sql-null? id))
-         (not (equal? "" id)))
-    (string-append "/posts/" id)
-    "/"))
-
+(define (get-next-path)
+  (let ([next ((request-vars 'query-string) 'next as-string)])
+    (if (irregex-match "^/posts/[0-9]*$" next)
+      next
+      "/")))
 
 (define routes
   `(
@@ -256,13 +268,13 @@
     (GET (/ "unvote") ,(lambda (rt)
                             (unvote (get-current-user))
                            (send-response
-                             headers: `((location "/"))
+                             headers: `((location ,(get-next-path)))
                              status: 'see-other
                              )))
     (GET (/ "vote-to-flush") ,(lambda (rt)
                             (let ([user (get-current-user)]) (when user (vote-to-flush user)))
                             (send-response
-                              headers: `((location "/"))
+                              headers: `((location ,(get-next-path)))
                               status: 'see-other
                               )))
     (GET (/ "login") ,(lambda (rt) (send-response