(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 (define db (open-database (or (get-environment-variable "DB_FILE") "/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 parent-id) (let ([id (pseudo-random-integer 281474976710655)]) (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) (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 (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.parent_id = p.id WHERE p.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.parent_id = p.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.parent_id = p.id WHERE p.parent_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 ASC LIMIT 25" post-id)) (define (delete-post post-id current-user) (first-result db "DELETE FROM posts WHERE id = ? AND user_id = ? RETURNING parent_id" post-id current-user)) ;(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-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" )] [class "delete-button"]) "[delete]") '()) (p (@ [style "min-height:0.5em"]) ,(content p)) (div [@ (class "post-info")] (em "- " ,(user p)) (span (@ [style "float:right;"]) (a (@ [href ,uri] [style "margin-right:2px;"]) "[" ,(children-count p) " comments]") ,(created-at p) ))))) (define (new-post-form parent-id) `(form (@ [class "new-post-form"] [action "/"] [method "POST"]) (input (@ [type "hidden"] [id "parent_id"] [name "parent_id"] [value ,(or parent-id "")])) (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-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 ,(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)))) (define (posts-page current-user displayed-posts) (posts-page-outer "/" current-user `(span ,(navbar current-user '(h2 "Posts")) ,(if current-user (new-post-form #f) '()) ,(if (null? displayed-posts) "no posts yet!" (map (cut post current-user <>) displayed-posts)) ))) (define (navbar current-user . inner) `(div (@ [class "navbar"]) ,(if current-user '(a (@ [style "float:right;"] [href "/logout"]) logout) '(a (@ [style "float:right;"] [href "/login"]) login)) ,inner )) (define (post-page current-user p comments) (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]) "return")) ,(post current-user p) (h3 "Comments") ,(if (null? comments) "no comments yet!" (map (cut post current-user <>) comments)) ,(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 "/"))) (define routes `( (GET (/ "style.css") ,(lambda (rt) (send-static-file "style.css"))) (GET (/ "favicon.ico") ,(lambda (rt) (send-static-file "favicon.ico"))) (GET (/ "unvote") ,(lambda (rt) (unvote (get-current-user)) (send-response 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 ,(get-next-path))) 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))] [parent-id (cdr (assv 'parent_id form-data))] [user (get-current-user)] [success? (if user (create-post user content parent-id) #f)]) (send-response headers: `((location ,(post-path parent-id))) 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)]) (send-response headers: '((content-type text/html)) status: 'ok body: (post-page current-user post comments))))) ; Has method GET so that it can be used from tag links (GET (/ "posts" ":id" "delete") ,(lambda (rt) (let* ([current-user (get-current-user)] [post-id (get-route-param rt "id")] [parent-id (delete-post post-id current-user)]) (if parent-id (send-response headers: `((location ,(post-path parent-id))) status: 'see-other) (send-status 'internal-server-error "Deletion Failed"))))) (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"))))) (root-path ".") (vhost-map `((".*" . ,handle))) (start-server port: 7080)