1 files changed, 52 insertions, 3 deletions

diff --git a/main.scm b/main.scm
index 0027a30..acb9363 100644
--- a/main.scm
+++ b/main.scm
@@ -7,6 +7,7 @@
   srfi-69 ;hash tables
   srfi-1 ;list functions
   srfi-4 ;u8vector
+  stb-image stb-image-resize stb-image-write
 )
 
 
@@ -137,6 +138,54 @@
 (define (children-count p) (sixth p))
 (define (has-image? p) (= 1 (seventh p)))
 
+
+
+
+
+(define dim-max 512)
+
+(define (target-dimensions width height)
+  ; case: both within limits -> return values
+  (if (and (> dim-max width) (> dim-max height))
+    (values width height)
+    ; case: either larger -> scale largest down to limit, scale smallest down by same amount
+  (let* (
+         [width-is-bigger (> width height)]
+         [big-dim (if width-is-bigger width height)]
+         [small-dim (if width-is-bigger height width)]
+         [scale-factor (quotient big-dim dim-max)]
+         [scaled-small-dim (quotient small-dim scale-factor)])
+    (if width-is-bigger
+      (values dim-max scaled-small-dim)
+      (values scaled-small-dim dim-max)
+      ))))
+
+(define (img->jpeg-blob img)
+  
+(with-output-to-file "/tmp/raw.jpg" (lambda () (display (blob->string (u8vector->blob img)))))
+
+
+  (let*-values ([(raw width height channels) (load-image img)]
+                [(target-width target-height) (target-dimensions width height)])
+(with-output-to-file "/tmp/test2.png"
+        (lambda ()
+          (write-png
+            raw
+            width
+            height
+            channels)
+          ))
+    (string->blob
+      (with-output-to-string
+        (lambda ()
+          (write-jpg
+            (image-resize raw width height channels target-width target-height)
+            target-width
+            target-height
+            channels)
+          )))))
+
+
 (define users (alist->hash-table '(("lawrence" . "pw") ("demo" . "pw") ("dan" . "pw"))))
 
 (define apikeys (make-hash-table))
@@ -371,9 +420,9 @@
       p
       "/")))
 
-(define (get-image-bytes image-multipart)
+(define (get-image-u8vector image-multipart)
   (and (multipart-file? image-multipart)
-       (u8vector->blob (read-u8vector #f (multipart-file-port image-multipart)))))
+       (read-u8vector #f (multipart-file-port image-multipart))))
 
 (define routes
   `(
@@ -429,7 +478,7 @@
                            [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)]
+                           [image (img->jpeg-blob (get-image-u8vector image-multipart))]
                            [user (get-current-user)]
                            [success? (and user (create-post user content parent-id image))])
                         (send-response