diff options
| -rw-r--r-- | main.scm | 106 |
1 files changed, 17 insertions, 89 deletions
@@ -1,13 +1,12 @@ (import - scheme (chicken base) (chicken foreign) (chicken file posix) (chicken file) - (chicken format) (chicken port) (chicken io) (chicken random) (chicken time) + 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 - stb-image stb-image-resize stb-image-write ) @@ -21,8 +20,7 @@ user_id TEXT, content TEXT, created_at DATETIME default current_timestamp, - parent_id TEXT, - jpeg_image BLOB + parent_id TEXT )") (execute db "CREATE TABLE flush_votes ( user_id TEXT PRIMARY KEY, @@ -34,22 +32,19 @@ (+ (pseudo-random-integer 65536) (* (current-seconds) 100000))) -(define (create-post user content parent-id image) +(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)] - [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))) + (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 (?)" @@ -64,16 +59,8 @@ "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 + "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 @@ -82,7 +69,7 @@ (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 + "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 = ? @@ -91,35 +78,21 @@ 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 . opts) - (let* ([page (or (and (not (null-list? opts)) (car opts)) 0)] - [limit 25] -; [start (* limit page)] -; [end (* limit (add1 page))] - ) + +(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 + "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 ?, ?" + ORDER BY count(c.id) DESC, p.created_at ASC " post-id - ; start end - ))) + )) (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 + "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 = ? @@ -226,8 +199,6 @@ (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 @@ -281,11 +252,6 @@ [class "delete-button"]) "[delete]") '()) - ,(if (has-image? p) - `(img (@ [src ,(string-append "/posts/image/" (id p))] - [style "max-width:100%;"] - [loading "lazy"])) - '()) (div (@ [class "content-container"]) ,(content->sxml (content p))) (div (@ [class "post-info"]) (em "- " (a (@ [href ,(user-path (user p))]) ,(user p))) @@ -311,16 +277,6 @@ [value ""] [rows "5"] [cols "50"]))) - (div (@ [class "image-upload"] - [style "display:none;"] - ) - (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"])) )) @@ -354,8 +310,6 @@ (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)] @@ -389,12 +343,6 @@ (map (cut post current-user <>) posts)) ))) -(define (dialog text) - `(dialog (@ [open "true"] [style "min-width:30vw"]) - (p ,text) - (form (@ [method "dialog"]) - (button "OK")))) - (define (posts-page current-user displayed-posts) (posts-page-outer "/" current-user `(span @@ -447,10 +395,6 @@ p "/"))) -(define (get-image-u8vector image-multipart) - (and (multipart-file? image-multipart) - (read-u8vector #f (multipart-file-port image-multipart)))) - (define routes `( (GET (/ "style.css") ,(lambda (rt) @@ -506,10 +450,8 @@ (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 (img->jpeg-blob (get-image-u8vector image-multipart))] [user (get-current-user)] - [success? (and user (create-post user content parent-id image))]) + [success? (and user (create-post user content parent-id))]) (send-response headers: `((location ,(post-path parent-id))) status: 'see-other @@ -532,25 +474,11 @@ 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) - (cache-control - (max-age . 604800) public immutable)) - 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)] - [page-num ((request-vars 'query-string) 'page as-number)] - [comments (and post (get-child-posts post-id page-num))]) + [comments (and post (get-child-posts post-id))]) (if post (send-response headers: '((content-type text/html)) |