(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 stylesheet (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, p.created_at 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, p.created_at 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 '(("lawrence" . "pw") ("demo" . "pw") ("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 (link (@ [rel "stylesheet"] [href "/style.css"])) (meta (@ [name "viewport"] [content "width=device-width, initial-scale=1"]))) (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!" "Vote for a Purge!")]) (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 (/ "style.css") ,(lambda (rt) (send-response headers: `((content-type text/css)) status: 'ok body: stylesheet ))) (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 continue) (let* ((uri (request-uri (current-request))) (method (request-method (current-request))) (route (find-route uri method))) (if route ((third route) route) (begin (display uri ) (display method) (send-status 'not-found "Page Not Found"))))) (vhost-map `((".*" . ,handle))) (start-server port: 7080)