feat: posts can have an image

3 files changed, 106 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)))
diff --git a/nginx.conf b/nginx.conf
index b5c5c40..8f33791 100644
--- a/nginx.conf
+++ b/nginx.conf
@@ -5,6 +5,7 @@ upstream itter {
 server {
         listen 443 ssl;
         server_name 54itter.dotemgo.com;
+        client_max_body_size 10m;
 
         ssl_certificate     /root/dotemgo.com.pem.crt;
         ssl_certificate_key /root/dotemgo.com.pem.key;
diff --git a/style.css b/style.css
index 2b8fc44..890b398 100644
--- a/style.css
+++ b/style.css
@@ -162,3 +162,19 @@ textarea {
 .navbar {
     height: 2em;
 }
+
+#image::file-selector-button {
+    border: 0;
+    line-height: 2.5;
+    padding: 0 20px;
+    font-size: 1rem;
+    text-align: center;
+    color: #fff;
+    text-shadow: 1px 1px 1px #000;
+    border-radius: 10px;
+    background-color: rgba(0, 0, 240, 0.6);
+    background-image: linear-gradient(to top left, rgba(0, 0, 0, 0.2), rgba(0, 0, 0, 0.2) 30%, rgba(0, 0, 0, 0));
+    box-shadow: inset 2px 2px 3px rgba(255, 255, 255, 0.6), inset -2px -2px 3px rgba(0, 0, 0, 0.6);
+    margin-top:2px;
+    cursor: pointer;
+}