summaryrefslogtreecommitdiffstats
path: root/main.scm
diff options
context:
space:
mode:
Diffstat (limited to 'main.scm')
-rw-r--r--main.scm124
1 files changed, 89 insertions, 35 deletions
diff --git a/main.scm b/main.scm
index ffdc081..175c0e1 100644
--- a/main.scm
+++ b/main.scm
@@ -1,11 +1,12 @@
(import
scheme (chicken base)
(chicken format) (chicken port) (chicken io) (chicken random) (chicken time)
- (chicken process-context) (chicken irregex) (chicken condition)
- spiffy intarweb uri-common html-parser spiffy-request-vars
+ (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
)
@@ -19,7 +20,8 @@
user_id TEXT,
content TEXT,
created_at DATETIME default current_timestamp,
- parent_id TEXT
+ parent_id TEXT,
+ jpeg_image BLOB
)")
(execute db "CREATE TABLE flush_votes (
user_id TEXT PRIMARY KEY,
@@ -31,13 +33,19 @@
(+ (pseudo-random-integer 65536)
(* (current-seconds) 100000)))
-(define (create-post user content parent-id)
- (let ([id (gen-id)])
- (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 (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)])
+ (execute db "insert into posts
+ (id, user_id, content, parent_id, jpeg_image)
+ values (?, ?, ?, ?, ?)"
+ id user content parent-id-or-null image-or-null)))
(define (vote-to-flush user)
(execute db "insert or ignore into flush_votes (user_id) values (?)"
@@ -61,16 +69,16 @@
; (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)
+ "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)
+ "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 = ?
@@ -79,9 +87,18 @@
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)
+ "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 = ?
@@ -90,7 +107,7 @@
(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)
+ "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 = ?
@@ -115,6 +132,7 @@
(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"))))
@@ -138,9 +156,10 @@
(define (get-prev-path) (get-cookie "prev"))
-(define (post-path id)
+(define (post-path id)
(if
(and id
+ (not (eof-object? id))
(not (sql-null? id))
(not (equal? "" id)))
(string-append "/posts/" id)
@@ -156,9 +175,11 @@
)
+(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 (find (cut equal? <> 'hide-comments-link) opts)])
+ [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
@@ -168,6 +189,11 @@
[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;"]) ,(content p))
(div [@ (class "post-info")]
(em "- " (a (@ [href ,(user-path (user p))]) ,(user p)))
@@ -178,21 +204,31 @@
)))))
(define (new-post-form parent-id)
- `(form (@ [class "new-post-form"] [action "/"] [method "POST"])
+ `(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
+ (span
(textarea (@ [maxlength "540"]
[id "content"]
[name "content"]
[value ""]
[rows "5"]
[cols "50"])))
- (input (@ [id "submit"] [type "submit"] [value "Post"]))))
-
-(define (page inner)
+ (input (@ [id "submit"] [type "submit"] [value "Post"]))
+ (label (@ [for "image"] [style "margin-left:1em"]) Image:)
+ (input (@ [type "file"]
+ [id "image"]
+ [accept "image/jpeg"]
+ [name "image"]
+ [style "margin-left:0.5em"]))
+ ))
+
+(define (page inner)
(with-output-to-string (lambda ()
(sxml-display-as-html
`(html (head
@@ -298,10 +334,6 @@
(define (get-next-path)
(get-qp-path 'next))
-
-;; Use cookie instead???
-
-
(define allowed-return-paths
'("^/posts/[0-9]*$"
"^/users/[A-z0-9_-]*$"))
@@ -312,27 +344,32 @@
p
"/")))
-
-;(define (set-prev-cookie) `(set-cookie #(("prev" . ,(current-request-path-string)) ())))
+(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
@@ -340,6 +377,7 @@
(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))]
@@ -350,6 +388,7 @@
(set-cookie
#(("apikey" . ,apikey) ())))
status: 'see-other))))
+
(GET (/ "logout") ,(lambda (rt)
(send-response
headers: `((location "/")
@@ -357,17 +396,21 @@
#(("apikey" . "") ()))) ; should also wipe server-side keys
status: 'see-other
)))
+
(POST (/ "") ,(lambda (rt)
- (let* ([form-data (read-urlencoded-request-data (current-request))]
+ (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? (if user (create-post user content parent-id) #f)])
+ [success? (and user (create-post user content parent-id image))])
(send-response
headers: `((location ,(post-path parent-id)))
status: 'see-other
))))
- (GET (/ "") ,(lambda (rt)
+
+ (GET (/ "") ,(lambda (rt)
(let ([current-user (get-current-user)]
[displayed-posts (top-posts)])
(send-response
@@ -384,20 +427,31 @@
status: 'ok
body: (user-page current-user user-id posts)))))
- (GET (/ "posts" ":id") ,(lambda (rt)
+ (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))
+ 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)
+ (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)])
@@ -435,7 +489,7 @@
(uri-path uri)
(second r))))
routes))
-
+
(define (handle continue)
(let* ((uri (request-uri (current-request)))
(method (request-method (current-request)))
generated by cgit v1.2.3 (git 2.25.1) at 2025-05-23 11:05:47 +0000