(import
scheme (chicken base)
(chicken format) (chicken port) (chicken io) (chicken random) (chicken time)
(chicken process-context) (chicken irregex) (chicken condition) (chicken blob)
spiffy intarweb uri-common html-parser spiffy-request-vars multipart-form-data
sqlite3 sql-null
srfi-69 ;hash tables
srfi-1 ;list functions
srfi-4 ;u8vector
)
;; 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,
jpeg_image BLOB
)")
(execute db "CREATE TABLE flush_votes (
user_id TEXT PRIMARY KEY,
created_at DATETIME default current_timestamp
)")
)
(define (gen-id)
(+ (pseudo-random-integer 65536)
(* (current-seconds) 100000)))
(define (create-post user content parent-id image)
(let ([id (gen-id)]
[parent-id-or-null (if (or (not parent-id) (eof-object? parent-id) (equal? "" parent-id))
(sql-null)
parent-id)]
[image-or-null (if (or (not image) (eof-object? image) (equal? "" image))
(sql-null)
image)]
[content-or-empty (if (or (not content) (eof-object? content))
""
content)])
(execute db "insert into posts
(id, user_id, content, parent_id, jpeg_image)
values (?, ?, ?, ?, ?)"
id user content-or-empty parent-id-or-null image-or-null)))
(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), p.jpeg_image is not null as has_image
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)
(condition-case (first-row db
"SELECT p.id, p.user_id, p.content, p.created_at, p.parent_id, count(c.id), p.jpeg_image is not null as has_image
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)
[(exn sqlite3) #f]))
(define (get-post-image post-id)
(condition-case (first-result db
"SELECT p.jpeg_image
FROM posts p
WHERE p.id = ?"
post-id)
[(exn sqlite3) #f]))
(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), p.jpeg_image is not null as has_image
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 (get-user-posts user-id)
(map-row list db
"SELECT p.id, p.user_id, p.content, p.created_at, p.parent_id, count(c.id), p.jpeg_image is not null as has_image
FROM posts p
LEFT JOIN posts c ON c.parent_id = p.id
WHERE p.parent_id IS NULL AND p.user_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 DESC LIMIT 25" user-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 (has-image? p) (= 1 (seventh 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-cookie key)
(let* ([headers (request-headers (current-request))]
[cookies (header-values 'cookie headers)])
(alist-ref key cookies equal?)))
(define (get-current-user)
(let ([apikey (get-cookie "apikey")])
(if apikey (lookup-user apikey) #f)))
(define (get-prev-path) (get-cookie "prev"))
(define (post-path id)
(if
(and id
(not (eof-object? id))
(not (sql-null? id))
(not (equal? "" id)))
(string-append "/posts/" id)
"/"))
(define (user-path id)
(if
(and id
(not (sql-null? id))
(not (equal? "" id)))
(string-append "/users/" id)
"/")
)
(define (get-opt opt opts) (find (cut equal? <> opt) opts))
(define (post current-user p . opts)
(let ([uri (post-path (id p))]
[hide-comments-link (get-opt 'hide-comments-link opts)])
`(div (@ [class "post"] [id ,(id p)])
,(if (equal? current-user (user p))
`(a (@ [href ,(string-append
uri
"/delete"
)]
[class "delete-button"])
"[delete]")
'())
,(if (has-image? p)
`(img (@ [src ,(string-append "/posts/image/" (id p))]
[style "max-width:100%;"]
[loading "lazy"]))
'())
(p (@ [style "min-height:0.5em;white-space:pre-wrap;"]) ,(content p))
(div [@ (class "post-info")]
(em "- " (a (@ [href ,(user-path (user p))]) ,(user p)))
(span (@ [style "float:right;"])
,(if hide-comments-link '() `(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"]
[enctype "multipart/form-data"])
(input (@ [type "hidden"]
[id "parent_id"]
[name "parent_id"]
[value ,(or parent-id "")]))
(span
(textarea (@ [maxlength "540"]
[id "content"]
[name "content"]
[value ""]
[rows "5"]
[cols "50"])))
(div (@ [class "image-upload"])
(label (@ [for "image"]
[style "margin-right:0.1em"])
"Add Image")
(input (@ [type "file"]
[id "image"]
[accept "image/jpeg"]
[name "image"])))
(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
,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!"
"Unclog the bog!"
"Incinerate everything!"
"Vote for a Purge!")])
(list-ref prompts (pseudo-random-integer (length prompts)))))
(define (current-request-path) (uri-path (request-uri (current-request))))
(define (current-request-path-string)
(apply string-append (cons "/" (intersperse (cdr (current-request-path)) "/"))))
(define (get-route-param route param)
(let ([pattern (second route)]
[path (current-request-path)])
(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 (user-page current-user user posts)
(posts-page-outer (user-path user) current-user
`(span
,(navbar current-user '(a (@ [href "/"]) "home"))
(h2 ,user)
,(if (and current-user (equal? current-user user)) (new-post-form #f) '())
,(if (null? posts)
"no posts yet!"
(map (cut post current-user <>) posts))
)))
(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])
,(if (equal? parent-path "/") "home" "parent")))
,(post current-user p 'hide-comments-link)
(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)
(get-qp-path 'next))
(define allowed-return-paths
'("^/posts/[0-9]*$"
"^/users/[A-z0-9_-]*$"))
(define (get-qp-path qp)
(let ([p ((request-vars 'query-string) qp as-string)])
(if (and p (any (cut irregex-match <> p) allowed-return-paths))
p
"/")))
(define (get-image-bytes image-multipart)
(and (multipart-file? image-multipart)
(u8vector->blob (read-u8vector #f (multipart-file-port image-multipart)))))
(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-multipart-form-data (current-request))]
[content (cdr (assv 'content form-data))]
[parent-id (cdr (assv 'parent_id form-data))]
[image-multipart (cdr (assv 'image form-data))]
[image (get-image-bytes image-multipart)]
[user (get-current-user)]
[success? (and user (create-post user content parent-id image))])
(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 (/ "users" ":id") ,(lambda (rt)
(let* ([current-user (get-current-user)]
[user-id (get-route-param rt "id")]
[posts (get-user-posts user-id)])
(send-response
headers: '((content-type text/html))
status: 'ok
body: (user-page current-user user-id posts)))))
(GET (/ "posts" "image" ":id") ,(lambda (rt)
(let* ([post-id (get-route-param rt "id")]
[post-image (and post (get-post-image post-id))]
[post-image-string (and post-image (blob->string post-image))])
(if post-image-string
(send-response
headers: '((content-type image/jpeg))
status: 'ok
body: post-image-string)
(send-status 'not-found "This image no longer exists!")))))
(GET (/ "posts" ":id") ,(lambda (rt)
(let* ([current-user (get-current-user)]
[post-id (get-route-param rt "id")]
[post (get-post post-id)]
[comments (if post (get-child-posts post-id) #f)])
(if post
(send-response
headers: '((content-type text/html))
status: 'ok
body: (post-page current-user post comments))
(send-status 'not-found "This Post no longer exists!")))))
; Has method GET so that it can be used from <a> 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)