From 37db988e1aa49411e6000df64220aeebf8c4a198 Mon Sep 17 00:00:00 2001 From: dan Date: Mon, 27 Feb 2023 11:04:35 -0500 Subject: init --- main.scm | 292 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 292 insertions(+) create mode 100644 main.scm (limited to 'main.scm') 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) -- cgit v1.2.3