init

1 files changed, 292 insertions, 0 deletions

diff --git a/main.scm b/main.scm
new file mode 100644
index 0000000..c36e59f
--- /dev/null
+++ b/main.scm
@@ -0,0 +1,292 @@
+(import (chicken format) (srfi-1))
+(import spiffy intarweb uri-common html-parser (chicken port))
+(import (chicken io))
+(import sqlite3)
+(import srfi-69)
+(import (chicken random))
+
+
+;; db open and create
+
+(define db (open-database "/tmp/54itter.db"))
+
+(when (zero? (first-result db "SELECT count(*) FROM sqlite_master WHERE type='table' AND name='posts'"))
+    (execute db "CREATE TABLE posts (
+                    id TEXT PRIMARY KEY,
+                    user_id TEXT,
+                    content TEXT,
+                    created_at DATETIME default current_timestamp,
+                    parent_id TEXT
+                )")
+    (execute db "CREATE TABLE flush_votes (
+                    user_id TEXT PRIMARY KEY,
+                    created_at DATETIME default current_timestamp
+                )")
+    )
+
+(define (create-post user content)
+  (let ([id (pseudo-random-integer 281474976710655)])
+    (execute db "insert into posts (id, user_id, content) values (?, ?, ?)"
+             id user content)))
+
+(define (vote-to-flush user)
+    (execute db "insert or ignore into flush_votes (user_id) values (?)"
+             user))
+(define (unvote user)
+    (execute db "delete from flush_votes where user_id = ?" user))
+
+
+(define (vote-count) (first-result db "SELECT count(*) FROM flush_votes"))
+
+(define (user-has-voted user) (= 1 (first-result db
+                                        "SELECT count(*) FROM flush_votes WHERE user_id = ?"
+                                        user)))
+
+;;
+
+;(define (read-request-string request)
+;  (let* ((p (request-port request))
+;        (len (header-value 'content-length (request-headers request)))
+;        (port (request-port request)))
+;                    (read-u8vector len port)))
+
+(define style (read-string #f
+  (open-input-file "./style.css" #:text)))
+
+(define (top-posts) (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.id = p.parent_id
+                WHERE c.parent_id IS NULL
+                GROUP BY p.id, p.user_id, p.content, p.created_at, p.parent_id
+                ORDER BY count(c.id) DESC LIMIT 25"))
+
+
+
+(define (get-post post-id)
+  (first-row 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.id = p.parent_id
+                    WHERE p.id = ?
+                    GROUP BY p.id, p.user_id, p.content, p.created_at, p.parent_id
+                    ORDER BY count(c.id) DESC LIMIT 1"
+                post-id))
+
+(define (get-child-posts post-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.id = p.parent_id
+                WHERE c.parent_id IS ?
+                GROUP BY p.id, p.user_id, p.content, p.created_at, p.parent_id
+                ORDER BY count(c.id) DESC LIMIT 25" post-id))
+
+;(define (top-posts) (map-row list db
+;            "SELECT id, user_id, content, created_at
+;                FROM posts
+;                WHERE parent_id IS NULL
+;                ORDER BY created_at DESC LIMIT 25"))
+
+
+(define (id p) (first p))
+(define (user p) (second p))
+(define (content p) (third p))
+(define (created-at p) (fourth p))
+(define (parent-id p) (fifth p))
+(define (children-count p) (sixth p))
+
+(define users (alist->hash-table '(("dan" . "pw"))))
+
+(define apikeys (make-hash-table))
+
+(define (login username password)
+  (let ([apikey (number->string (pseudo-random-integer 340282366920938463463374607431768211455))])
+      (hash-table-set! apikeys apikey username)
+      apikey))
+
+(define (lookup-user apikey) (hash-table-ref/default apikeys apikey #f))
+
+(define (get-current-user)
+  (let* ([headers (request-headers (current-request))]
+         [cookie (header-value 'cookie headers)]
+         [apikey (if cookie (cdr cookie) #f)])
+    (if apikey (lookup-user apikey) #f)))
+
+(define (post p)
+  `(div (@ [class "post"] [id ,(id p)])
+        (p ,(content p))
+        (div [@ (class "author")]
+             (em "- " ,(user p))
+             (span (@ [style "float:right;"])
+                   (a (@ [href ,(string-append "/posts/" (id p))] [style "margin-right:2px;"])
+                      ,(children-count p) " comments")
+                   ,(created-at p)
+                   ))
+        ))
+
+(define new-post-form
+  `(form (@ [class "new-post-form"] [action "/"] [method "POST"])
+  (span 
+      (textarea (@ [id "content"] [name "content"] [value ""] [rows "5"] [cols "50"])))
+  (input (@ [id "submit"] [type "submit"] [value "Post"]))))
+
+(define (page inner) 
+  (with-output-to-string (lambda ()
+    (sxml-display-as-html
+      `(html (head (style ,style))
+             (body
+;               (h1 "Title")
+;               (a (@ [href "/"]) "Back")
+               ,inner
+               ))))))
+
+(define login-form
+  `(form (@ [class "login-form"] [action "/login"] [method "POST"])
+    (div
+  (div (label (@ [for "username"]) "Username:")
+      (input (@ [type "text"] [id "username"] [name "username"] [value ""])))
+  (div (label (@ [for "password"]) "Password:")
+      (input (@ [type "password"] [id "password"] [name "password"] [value ""])))
+  (input (@ [id "submit"] [type "submit"] [value "Submit"])))))
+
+(define (vote-to-flush-prompt)
+  (let ([prompts '("Flush it all away!")]) ; "Drain the swamp!" "Unclog the bog!")])
+    (list-ref prompts (pseudo-random-integer (length prompts)))))
+
+
+(define (get-route-param route param)
+  (let ([pattern (second route)]
+        [path (uri-path (request-uri (current-request)))])
+  (first (find
+           (lambda (x) (equal? (second x) (string-append ":" param)))
+           (zip path pattern)))))
+
+(define (posts-page current-user displayed-posts) (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)))
+                                     '())
+                                  (div "Votes so far: " ,(vote-count))
+                                  (div
+                                    ,(if current-user
+                                       '(a (@ [style "float:right;"] [href "/logout"]) logout)
+                                       '(a (@ [style "float:right;"] [href "/login"]) login))
+                                    (h2 "Posts")
+                                    ,(if current-user new-post-form '())
+                                    ,(if (null? displayed-posts)
+                                       "No posts yet!"
+                                       (map post displayed-posts))
+                                    )
+                                  )))
+
+(define routes
+  `(
+    (GET (/ "unvote") ,(lambda (rt)
+                            (unvote (get-current-user))
+                           (send-response
+                             headers: `((location "/"))
+                             status: 'see-other
+                             )))
+    (GET (/ "vote-to-flush") ,(lambda (rt)
+                            (let ([user (get-current-user)]) (when user (vote-to-flush user)))
+                            (send-response
+                              headers: `((location "/"))
+                              status: 'see-other
+                              )))
+    (GET (/ "login") ,(lambda (rt) (send-response
+                               headers: '((content-type text/html))
+                               status: 'ok
+                               body: (page `(div
+                                              (a (@ [style "float:right;"] [href "/"]) back)
+                                              (h2 "Login")
+                                              ,login-form)))))
+    (POST (/ "login") ,(lambda (rt)
+                         (let* ([form-data (read-urlencoded-request-data (current-request))]
+                                [username (cdr (assv 'username form-data))]
+                                [password (cdr (assv 'password form-data))]
+                                [apikey (login username password)])
+                           (send-response
+                             headers: `((location "/")
+                                        (set-cookie
+                                          #(("apikey" . ,apikey) ())))
+                             status: 'see-other))))
+    (GET (/ "logout") ,(lambda (rt)
+                           (send-response
+                             headers: `((location "/")
+                                        (set-cookie
+                                          #(("apikey" . "") ()))) ; should also wipe server-side keys
+                             status: 'see-other
+                             )))
+    (POST (/ "") ,(lambda (rt)
+                    (let* ([form-data (read-urlencoded-request-data (current-request))]
+                           [content (cdr (assv 'content form-data))]
+                           [user (get-current-user)]
+                           [success? (if user (create-post user content) #f)])
+                        (send-response
+                               headers: '((location "/"))
+                               status: 'see-other
+                               ))))
+    (GET (/ "") ,(lambda (rt) 
+                   (let ([current-user (get-current-user)]
+                         [displayed-posts (top-posts)])
+                     (send-response
+                       headers: '((content-type text/html))
+                       status: 'ok
+                       body: (posts-page current-user displayed-posts)))))
+
+
+
+(GET (/ "posts" ":id") ,(lambda (rt) 
+                   (let* ([current-user (get-current-user)]
+                         [post-id (get-route-param rt "id")]
+                         [post (get-post post-id)]
+                         [comments (get-child-posts post-id)]
+                         [displayed-posts (cons post comments)])
+                     (send-response
+                       headers: '((content-type text/html))
+                       status: 'ok
+                       body: (posts-page current-user displayed-posts)))))
+
+(GET (/ "posts") ,(lambda (rt)
+                           (send-response
+                             headers: `((location "/"))
+                             status: 'see-other
+                             )))
+
+    ))
+
+(define (route-patterns-match? req pat)
+  (and (= (length req) (length pat))
+       (every
+         (lambda (xy)
+           (let ([x (first xy)] [y (second xy)])
+             (or (equal? x y)
+                 (and (string? y) (< 0 (string-length y))
+                      (equal? #\: (string-ref y 0))))))
+         (zip req pat))))
+
+(define (find-route uri method)
+  (find
+           (lambda (r) (and
+                         (equal?
+                           method
+                           (first r))
+                         (route-patterns-match?
+                           (uri-path uri)
+                           (second r))))
+           routes))
+ 
+(define (handle-greeting continue)
+  (let* ((uri (request-uri (current-request)))
+         (method (request-method (current-request)))
+         (route (find-route uri method))
+         (handler (third route)))
+    (handler route)))
+
+(vhost-map `(("localhost" . ,handle-greeting)))
+(start-server port: 7080)