15 April 2023
Building a Mini Social Network in one file of Scheme - Part 1
I have been messing about with Chicken Scheme, building a little microblogging-style app, with a twist: users can vote for a purge of the whole site's content! I thought it would be fun to see how far I can get with one file of Scheme and without any JavaScript. I have put a favicon and some css in separate files, but really these could both be embedded in the Scheme file aswell - but that would be taking it a bit too far.
If you skim the Scheme below, several issues will become obvious to you. Perhaps most saliently, the USP feature is not actually fully implemented - users can vote to purge the server, but the purge action itself has not been added. Secondly, the users and passwords are simply hardcoded into an association list. I've dumped the code below, and at some point I will tidy up a few of the loose ends, make the GitHub repo public, and perhaps write further about it.
The following code is free for anyone to use/copy/adapt, but should be considered a toy and an example. I do not claim it to be fit for any purpose.
(import
scheme (chicken base)
(chicken format) (chicken port) (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 / create
(define db (open-database (or (get-environment-variable "DB_FILE") "/tmp/54itter.db")))
;; create db on first run
(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
)")
)
;; generate a new id
;; IDs should be in chronological order and extremely unlikely to clash
(define (gen-id)
(+ (pseudo-random-integer 65536)
(* (current-seconds) 100000)))
;;;; DB Queries
(define (create-post user content parent-id)
(let ([id (gen-id)]
[parent-id-or-null (if (or (not parent-id) (eof-object? parent-id) (equal? "" parent-id))
(sql-null)
parent-id)]
[content-or-empty (if (or (not content) (eof-object? content))
""
content)])
(execute db "insert into posts
(id, user_id, content, parent_id)
values (?, ?, ?, ?)"
id user content-or-empty parent-id-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 (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)
(condition-case (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)
[(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)
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 "
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)
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))
;; getters to extract values from rows returned by queries
(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))
;; Users List
(define users (alist->hash-table '(("example" . "pw"))))
(define apikeys (make-hash-table))
;; Return apikey is username&password combo are correct, else return #f
(define (login username password)
(let ([pw-in-db (hash-table-ref/default users username #f)])
(and password (equal? password pw-in-db)
(let ([apikey (number->string (pseudo-random-integer 340282366920938463463374607431768211455))])
(hash-table-set! apikeys apikey username)
apikey))))
;; lookup user by apikey, return user_id or #f
(define (lookup-user apikey) (hash-table-ref/default apikeys apikey #f))
;; Get a cookie from the headers
(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 (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))
;;;; SXML Views / View Helpers
;; Turns user content into an sxml tree (so that links in the text can be added as working links)
(define (content->sxml content)
(let ([r "(https://[^ ]*)"])
(if (irregex-search r content)
(let* ([starts-with-link (= 0 (irregex-match-start-index (irregex-search r content)))]
[texts (map (cut list 'span <>) (irregex-split r content))]
[links (map (lambda (x)
`(a (@ [href ,x]
[target "_blank"]
[rel "noreferrer"])
,x)) (irregex-extract r content))])
(define (go xs ys take-y?)
(cond
[(and (not (null-list? ys)) take-y?)
(cons (car ys) (go xs (cdr ys) #f))]
[(and (not (null-list? xs)) (not take-y?))
(cons (car xs) (go (cdr xs) ys #t))]
[else '()]
))
(go texts links starts-with-link))
`(p ,content))))
(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]")
'())
(div (@ [class "content-container"]) ,(content->sxml (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"])))
(input (@ [id "submit"] [type "submit"] [value "Post"]))
))
(define (page inner)
(string-append
"<!DOCTYPE html>"
(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 (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)) '())))))
;;;; Routing
(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 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)])
(if apikey
(send-response
headers: `((location "/")
(set-cookie
#(("apikey" . ,apikey) ())))
status: 'see-other)
(send-status 'unauthorized)))))
(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))]
[user (get-current-user)]
[success? (and user (create-post user content parent-id))])
(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" ":id") ,(lambda (rt)
(let* ([current-user (get-current-user)]
[post-id (get-route-param rt "id")]
[post (get-post post-id)]
[comments (and post (get-child-posts post-id))])
(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))
;; Handler
(define (handle continue)
(let* ([req (current-request)]
[uri (request-uri req)]
[method (request-method req)]
[route (find-route uri method)])
(if route
((third route) route)
(begin (display uri) (display method) (send-status 'not-found "Page Not Found")))))
;;;; Spiffy Server Initialisation
(root-path ".")
(vhost-map `((".*" . ,handle)))
(start-server port: 7080)